1 /*
2 * ArithmeticProcedures.cpp - arithmetic procedures.
3 *
4 * Copyright (c) 2008 Higepon(Taro Minowa) <higepon@users.sourceforge.jp>
5 * Copyright (c) 2008 Kokosabu(MIURA Yasuyuki) <kokosabu@gmail.com>
6 *
7 * Redistribution and use in source and binary forms, with or without
8 * modification, are permitted provided that the following conditions
9 * are met:
10 *
11 * 1. Redistributions of source code must retain the above copyright
12 * notice, this list of conditions and the following disclaimer.
13 *
14 * 2. Redistributions in binary form must reproduce the above copyright
15 * notice, this list of conditions and the following disclaimer in the
16 * documentation and/or other materials provided with the distribution.
17 *
18 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29 *
30 * $Id: ArithmeticProcedures.cpp 183 2008-07-04 06:19:28Z higepon $
31 */
32
33 #include "Object.h"
34 #include "Object-inl.h"
35 #include "SString.h"
36 #include "Pair.h"
37 #include "Pair-inl.h"
38 #include "ArithmeticProcedures.h"
39 #include "ProcedureMacro.h"
40 #include "Arithmetic.h"
41 #include "Ratnum.h"
42 #include "Fixnum.h"
43 #include "Flonum.h"
44 #include "Bignum.h"
45 #include "ProcedureMacro.h"
46 #include "Compnum.h"
47 #include "TextualOutputPort.h"
48
49 using namespace scheme;
50
makePolarEx(VM * theVM,int argc,const Object * argv)51 Object scheme::makePolarEx(VM* theVM, int argc, const Object* argv)
52 {
53 DeclareProcedureName("make-polar");
54 checkArgumentLength(2);
55 argumentCheckNumber(0, n1);
56 argumentCheckNumber(1, n2);
57 return Arithmetic::makePolar(n1, n2);
58 }
59
exptEx(VM * theVM,int argc,const Object * argv)60 Object scheme::exptEx(VM* theVM, int argc, const Object* argv)
61 {
62 DeclareProcedureName("expt");
63 checkArgumentLength(2);
64 argumentCheckNumber(0, n1);
65 argumentCheckNumber(1, n2);
66 if (n2.isBignum()) {
67 callImplementationRestrictionAfter(theVM, procedureName, "too big", Pair::list2(n1, n2));
68 return Object::Undef;
69 } else {
70 return Arithmetic::expt(n1, n2);
71 }
72 }
73
sqrtEx(VM * theVM,int argc,const Object * argv)74 Object scheme::sqrtEx(VM* theVM, int argc, const Object* argv)
75 {
76 DeclareProcedureName("sqrt");
77 checkArgumentLength(1);
78 argumentCheckNumber(0, n);
79 return Arithmetic::sqrt(n);
80 }
81
acosEx(VM * theVM,int argc,const Object * argv)82 Object scheme::acosEx(VM* theVM, int argc, const Object* argv)
83 {
84 DeclareProcedureName("acos");
85 checkArgumentLength(1);
86 argumentCheckNumber(0, n);
87 return Arithmetic::acos(n);
88 }
89
atanEx(VM * theVM,int argc,const Object * argv)90 Object scheme::atanEx(VM* theVM, int argc, const Object* argv)
91 {
92 DeclareProcedureName("atan");
93 checkArgumentLengthBetween(1, 2);
94 if (argc == 1) {
95 argumentCheckNumber(0, n);
96 bool isDiv0Error = false;
97 const Object ret = Arithmetic::atan(n, isDiv0Error);
98 if (isDiv0Error) {
99 callAssertionViolationAfter(theVM, procedureName, "division by zero", L1(n));
100 return Object::Undef;
101 } else {
102 return ret;
103 }
104 } else {
105 argumentCheckReal(0, n1);
106 argumentCheckReal(0, n2);
107 return Arithmetic::atan2(n1, n2);
108 }
109 }
110
asinEx(VM * theVM,int argc,const Object * argv)111 Object scheme::asinEx(VM* theVM, int argc, const Object* argv)
112 {
113 DeclareProcedureName("asin");
114 checkArgumentLength(1);
115 argumentCheckNumber(0, n);
116 return Arithmetic::asin(n);
117 }
118
tanEx(VM * theVM,int argc,const Object * argv)119 Object scheme::tanEx(VM* theVM, int argc, const Object* argv)
120 {
121 DeclareProcedureName("tan");
122 checkArgumentLength(1);
123 argumentCheckNumber(0, n);
124 bool isDiv0Error = false;
125 const Object ret = Arithmetic::tan(n, isDiv0Error);
126 if (isDiv0Error) {
127 callAssertionViolationAfter(theVM, procedureName, "division by zero", L1(n));
128 return Object::Undef;
129 } else {
130 return ret;
131 }
132 }
133
sinEx(VM * theVM,int argc,const Object * argv)134 Object scheme::sinEx(VM* theVM, int argc, const Object* argv)
135 {
136 DeclareProcedureName("sin");
137 checkArgumentLength(1);
138 const Object ret = Arithmetic::sin(argv[0]);
139 if (ret.isUndef()) {
140 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "nonzero", L1(argv[0]));
141 }
142 return ret;
143 }
144
cosEx(VM * theVM,int argc,const Object * argv)145 Object scheme::cosEx(VM* theVM, int argc, const Object* argv)
146 {
147 DeclareProcedureName("cos");
148 checkArgumentLength(1);
149 const Object ret = Arithmetic::cos(argv[0]);
150 if (ret.isUndef()) {
151 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "nonzero", L1(argv[0]));
152 }
153 return ret;
154 }
155
logEx(VM * theVM,int argc,const Object * argv)156 Object scheme::logEx(VM* theVM, int argc, const Object* argv)
157 {
158 DeclareProcedureName("log");
159 checkArgumentLengthBetween(1, 2);
160 if (argc == 1) {
161 argumentCheckNumber(0, n);
162 if (Arithmetic::isExactZero(n)) {
163 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "nonzero", L1(n));
164 return Object::Undef;
165 }
166 return Arithmetic::log(n);
167 } else {
168 argumentCheckNumber(0, n1);
169
170 argumentCheckNumber(1, n2);
171 if (Arithmetic::isExactZero(n1) || Arithmetic::isExactZero(n2)) {
172 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "nonzero", L2(n1, n2));
173 return Object::Undef;
174 }
175 bool isDiv0Error = false;
176 const Object ret = Arithmetic::log(n1, n2, isDiv0Error);
177 if (isDiv0Error) {
178 callAssertionViolationAfter(theVM, procedureName, "division by zero", L2(n1, n2));
179 return Object::Undef;
180 } else {
181 return ret;
182 }
183 }
184 }
185
expEx(VM * theVM,int argc,const Object * argv)186 Object scheme::expEx(VM* theVM, int argc, const Object* argv)
187 {
188 DeclareProcedureName("exp");
189 checkArgumentLength(1);
190 argumentCheckNumber(0, n);
191 return Arithmetic::exp(n);
192 }
193
floorEx(VM * theVM,int argc,const Object * argv)194 Object scheme::floorEx(VM* theVM, int argc, const Object* argv)
195 {
196 DeclareProcedureName("floor");
197 checkArgumentLength(1);
198 argumentCheckReal(0, n);
199 return Arithmetic::floor(n);
200 }
201
ceilingEx(VM * theVM,int argc,const Object * argv)202 Object scheme::ceilingEx(VM* theVM, int argc, const Object* argv)
203 {
204 DeclareProcedureName("ceiling");
205 checkArgumentLength(1);
206 argumentCheckReal(0, n);
207 return Arithmetic::ceiling(n);
208 }
209
truncateEx(VM * theVM,int argc,const Object * argv)210 Object scheme::truncateEx(VM* theVM, int argc, const Object* argv)
211 {
212 DeclareProcedureName("truncate");
213 checkArgumentLength(1);
214 argumentCheckReal(0, n);
215 return Arithmetic::truncate(n);
216 }
217
roundEx(VM * theVM,int argc,const Object * argv)218 Object scheme::roundEx(VM* theVM, int argc, const Object* argv)
219 {
220 DeclareProcedureName("round");
221 checkArgumentLength(1);
222 argumentCheckReal(0, n);
223 return Arithmetic::round(n);
224 }
225
integerDivEx(VM * theVM,int argc,const Object * argv)226 Object scheme::integerDivEx(VM* theVM, int argc, const Object* argv)
227 {
228 DeclareProcedureName("div");
229 checkArgumentLength(2);
230 argumentCheckReal(0, n1);
231 argumentCheckReal(1, n2);
232
233 if (n1.isFlonum()) {
234 Flonum* const flonum = n1.toFlonum();
235 if (flonum->isInfinite() || flonum->isNan()) {
236 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "neither infinite nor a NaN", n1);
237 return Object::Undef;
238 }
239 }
240
241 if (n2.isFixnum()) {
242 const int fn2 = n2.toFixnum();
243 if (0 == fn2) {
244 callAssertionViolationAfter(theVM, procedureName, "div by 0 is not defined", Pair::list2(n1, n2));
245 return Object::Undef;
246 }
247 }
248 if (n2.isFlonum()) {
249 const double fn2 = n2.toFlonum()->value();
250 if (0.0 == fn2) {
251 LOG2("[~a ~a]", n1, n2);
252 callAssertionViolationAfter(theVM, procedureName, "div by 0.0 is not defined", Pair::list2(n1, n2));
253 return Object::Undef;
254 }
255 }
256
257 if (n1.isFixnum() && n2.isFixnum()) {
258 return Fixnum::integerDiv(n1.toFixnum(), n2.toFixnum());
259 } else if (n1.isFlonum() && n2.isFlonum()) {
260 return Flonum::integerDiv(n1.toFlonum(), n2.toFlonum());
261 } else {
262 bool isDiv0Error = false;
263 Object ret = Object::Undef;
264 if (Arithmetic::isNegative(n2)) {
265 ret = Arithmetic::negate(Arithmetic::floor(Arithmetic::div(n1, Arithmetic::negate(n2), isDiv0Error)));
266 } else {
267 ret = Arithmetic::floor(Arithmetic::div(n1, n2, isDiv0Error));
268 }
269 if (isDiv0Error) {
270 callAssertionViolationAfter(theVM, procedureName, "division by zero", Pair::list2(n1, n2));
271 return Object::Undef;
272 } else {
273 return ret;
274 }
275
276 }
277 }
278
integerDiv0Ex(VM * theVM,int argc,const Object * argv)279 Object scheme::integerDiv0Ex(VM* theVM, int argc, const Object* argv)
280 {
281 DeclareProcedureName("div0");
282 checkArgumentLength(2);
283 argumentCheckReal(0, n1);
284 argumentCheckReal(1, n2);
285 Object div = integerDivEx(theVM, argc, argv);
286 if (div.isUndef()) {
287 return Object::Undef;
288 }
289 Object mod = Arithmetic::sub(n1, Arithmetic::mul(div, n2));
290 // we can ignore isDiv0Error parameter of Arithmetic::div.
291 // Because we know division by zero never occur.
292 bool isDiv0Error = false;
293 if (Arithmetic::lt(mod, Arithmetic::abs(Arithmetic::div(n2, Object::makeFixnum(2), isDiv0Error)))) {
294 return div;
295 } else {
296 if (Arithmetic::isNegative(n2)) {
297 return Arithmetic::sub(div, Object::makeFixnum(1));
298 } else {
299 return Arithmetic::add(div, Object::makeFixnum(1));
300 }
301 }
302 }
303
absEx(VM * theVM,int argc,const Object * argv)304 Object scheme::absEx(VM* theVM, int argc, const Object* argv)
305 {
306 DeclareProcedureName("abs");
307 checkArgumentLength(1);
308 argumentCheckReal(0, n);
309 return Arithmetic::abs(n);
310 }
311
evenPEx(VM * theVM,int argc,const Object * argv)312 Object scheme::evenPEx(VM* theVM, int argc, const Object* argv)
313 {
314 DeclareProcedureName("even?");
315 checkArgumentLength(1);
316 argumentCheckIntegerValued(0, n);
317 return Object::makeBool(Arithmetic::isEven(n));
318 }
319
oddPEx(VM * theVM,int argc,const Object * argv)320 Object scheme::oddPEx(VM* theVM, int argc, const Object* argv)
321 {
322 DeclareProcedureName("odd?");
323 checkArgumentLength(1);
324 argumentCheckIntegerValued(0, n);
325 return Object::makeBool(!Arithmetic::isEven(n));
326 }
327
magnitudeEx(VM * theVM,int argc,const Object * argv)328 Object scheme::magnitudeEx(VM* theVM, int argc, const Object* argv)
329 {
330 DeclareProcedureName("magnitude");
331 checkArgumentLength(1);
332 argumentCheckNumber(0, number);
333 return Arithmetic::magnitude(number);
334 }
335
angleEx(VM * theVM,int argc,const Object * argv)336 Object scheme::angleEx(VM* theVM, int argc, const Object* argv)
337 {
338 DeclareProcedureName("angle");
339 checkArgumentLength(1);
340 argumentCheckNumber(0, number);
341 return Arithmetic::angle(number);
342 }
343
complexPEx(VM * theVM,int argc,const Object * argv)344 Object scheme::complexPEx(VM* theVM, int argc, const Object* argv)
345 {
346 DeclareProcedureName("complex?");
347 checkArgumentLength(1);
348 return Object::makeBool(argv[0].isComplex());
349 }
350
realPEx(VM * theVM,int argc,const Object * argv)351 Object scheme::realPEx(VM* theVM, int argc, const Object* argv)
352 {
353 DeclareProcedureName("real?");
354 checkArgumentLength(1);
355 return Object::makeBool(argv[0].isReal());
356 }
357
integerPEx(VM * theVM,int argc,const Object * argv)358 Object scheme::integerPEx(VM* theVM, int argc, const Object* argv)
359 {
360 DeclareProcedureName("integer?");
361 checkArgumentLength(1);
362 return Object::makeBool(argv[0].isInteger());
363 }
364
realValuedPEx(VM * theVM,int argc,const Object * argv)365 Object scheme::realValuedPEx(VM* theVM, int argc, const Object* argv)
366 {
367 DeclareProcedureName("real-valued?");
368 checkArgumentLength(1);
369 const Object n = argv[0];
370 if (n.isNumber()) {
371 return Object::makeBool(Arithmetic::isRealValued(n));
372 } else {
373 return Object::False;
374 }
375 }
376
rationalValuedPEx(VM * theVM,int argc,const Object * argv)377 Object scheme::rationalValuedPEx(VM* theVM, int argc, const Object* argv)
378 {
379 DeclareProcedureName("rational-valued?");
380 checkArgumentLength(1);
381 const Object n = argv[0];
382 if (n.isNumber()) {
383 return Object::makeBool(Arithmetic::isRationalValued(n));
384 } else {
385 return Object::False;
386 }
387 }
388
integerValuedPEx(VM * theVM,int argc,const Object * argv)389 Object scheme::integerValuedPEx(VM* theVM, int argc, const Object* argv)
390 {
391 DeclareProcedureName("integer-valued?");
392 checkArgumentLength(1);
393 const Object n = argv[0];
394 if (n.isNumber()) {
395 return Object::makeBool(Arithmetic::isIntegerValued(n));
396 } else {
397 return Object::False;
398 }
399 }
400
numeratorEx(VM * theVM,int argc,const Object * argv)401 Object scheme::numeratorEx(VM* theVM, int argc, const Object* argv)
402 {
403 DeclareProcedureName("numerator");
404 checkArgumentLength(1);
405 argumentCheckRational(0, rational);
406 return Arithmetic::numerator(rational);
407 }
408
denominatorEx(VM * theVM,int argc,const Object * argv)409 Object scheme::denominatorEx(VM* theVM, int argc, const Object* argv)
410 {
411 DeclareProcedureName("denominator");
412 checkArgumentLength(1);
413 argumentCheckRational(0, rational);
414 return Arithmetic::denominator(rational);
415 }
416
infinitePEx(VM * theVM,int argc,const Object * argv)417 Object scheme::infinitePEx(VM* theVM, int argc, const Object* argv)
418 {
419 DeclareProcedureName("infinite?");
420 checkArgumentLength(1);
421 argumentCheckReal(0, real);
422 if (real.isFlonum()) {
423 return Object::makeBool(real.toFlonum()->isInfinite());
424 } else {
425 return Object::False;
426 }
427 }
428
finitePEx(VM * theVM,int argc,const Object * argv)429 Object scheme::finitePEx(VM* theVM, int argc, const Object* argv)
430 {
431 DeclareProcedureName("finite?");
432 checkArgumentLength(1);
433 argumentCheckReal(0, real);
434 if (real.isFlonum()) {
435 return Object::makeBool(!real.toFlonum()->isInfinite());
436 } else {
437 return Object::True;
438 }
439 }
440
nanPEx(VM * theVM,int argc,const Object * argv)441 Object scheme::nanPEx(VM* theVM, int argc, const Object* argv)
442 {
443 DeclareProcedureName("nan?");
444 checkArgumentLength(1);
445 argumentCheckReal(0, real);
446 if (real.isFlonum()) {
447 return Object::makeBool(real.toFlonum()->isNan());
448 } else {
449 return Object::False;
450 }
451 }
452
exactPEx(VM * theVM,int argc,const Object * argv)453 Object scheme::exactPEx(VM* theVM, int argc, const Object* argv)
454 {
455 DeclareProcedureName("exact?");
456 checkArgumentLength(1);
457 argumentCheckNumber(0, number);
458 return Object::makeBool(Arithmetic::isExact(number));
459 }
460
inexactPEx(VM * theVM,int argc,const Object * argv)461 Object scheme::inexactPEx(VM* theVM, int argc, const Object* argv)
462 {
463 DeclareProcedureName("inexact?");
464 checkArgumentLength(1);
465 argumentCheckNumber(0, number);
466 return Object::makeBool(!Arithmetic::isExact(number));
467 }
468
realPartEx(VM * theVM,int argc,const Object * argv)469 Object scheme::realPartEx(VM* theVM, int argc, const Object* argv)
470 {
471 DeclareProcedureName("real-part");
472 checkArgumentLength(1);
473 argumentCheckNumber(0, n);
474 return Arithmetic::real(n);
475 }
476
imagPartEx(VM * theVM,int argc,const Object * argv)477 Object scheme::imagPartEx(VM* theVM, int argc, const Object* argv)
478 {
479 DeclareProcedureName("imag-part");
480 checkArgumentLength(1);
481 argumentCheckNumber(0, n);
482 return Arithmetic::imag(n);
483 }
484
numberPEx(VM * theVM,int argc,const Object * argv)485 Object scheme::numberPEx(VM* theVM, int argc, const Object* argv)
486 {
487 DeclareProcedureName("number?");
488 checkArgumentLength(1);
489 const Object obj = argv[0];
490 return Object::makeBool(obj.isNumber());
491 }
492
rationalPEx(VM * theVM,int argc,const Object * argv)493 Object scheme::rationalPEx(VM* theVM, int argc, const Object* argv)
494 {
495 DeclareProcedureName("rational?");
496 checkArgumentLength(1);
497 const Object obj = argv[0];
498 return Object::makeBool(obj.isRational());
499 }
500
bignumPEx(VM * theVM,int argc,const Object * argv)501 Object scheme::bignumPEx(VM* theVM, int argc, const Object* argv)
502 {
503 DeclareProcedureName("bignum?");
504 checkArgumentLength(1);
505 const Object obj = argv[0];
506 return Object::makeBool(obj.isBignum());
507 }
508
flonumPEx(VM * theVM,int argc,const Object * argv)509 Object scheme::flonumPEx(VM* theVM, int argc, const Object* argv)
510 {
511 DeclareProcedureName("flonum?");
512 checkArgumentLength(1);
513 return Object::makeBool(argv[0].isFlonum());
514 }
515
fixnumPEx(VM * theVM,int argc,const Object * argv)516 Object scheme::fixnumPEx(VM* theVM, int argc, const Object* argv)
517 {
518 DeclareProcedureName("fixnum?");
519 checkArgumentLength(1);
520 return Object::makeBool(argv[0].isFixnum());
521 }
522
makeRectangularEx(VM * theVM,int argc,const Object * argv)523 Object scheme::makeRectangularEx(VM* theVM, int argc, const Object* argv)
524 {
525 DeclareProcedureName("make-rectangular");
526 checkArgumentLength(2);
527 argumentCheckReal(0, real);
528 argumentCheckReal(1, imag);
529 return Object::makeCompnum(real, imag);
530 }
531
fixnumWidthEx(VM * theVM,int argc,const Object * argv)532 Object scheme::fixnumWidthEx(VM* theVM, int argc, const Object* argv)
533 {
534 DeclareProcedureName("fixnum-width");
535 checkArgumentLength(0);
536 return Object::makeFixnum(Fixnum::BITS);
537 }
538
leastFixnumEx(VM * theVM,int argc,const Object * argv)539 Object scheme::leastFixnumEx(VM* theVM, int argc, const Object* argv)
540 {
541 DeclareProcedureName("least-fixnum");
542 checkArgumentLength(0);
543 return Object::makeFixnum(Fixnum::MIN);
544 }
545
greatestFixnumEx(VM * theVM,int argc,const Object * argv)546 Object scheme::greatestFixnumEx(VM* theVM, int argc, const Object* argv)
547 {
548 DeclareProcedureName("greatest-fixnum");
549 checkArgumentLength(0);
550 return Object::makeFixnum(Fixnum::MAX);
551 }
552
inexactEx(VM * theVM,int argc,const Object * argv)553 Object scheme::inexactEx(VM* theVM, int argc, const Object* argv)
554 {
555 DeclareProcedureName("inexact");
556 checkArgumentLength(1);
557 argumentCheckNumber(0, number);
558 return Arithmetic::inexact(number);
559 }
560
exactEx(VM * theVM,int argc,const Object * argv)561 Object scheme::exactEx(VM* theVM, int argc, const Object* argv)
562 {
563 DeclareProcedureName("exact");
564 checkArgumentLength(1);
565 argumentCheckNumber(0, number);
566 return Arithmetic::exact(number);
567 }
568
maxEx(VM * theVM,int argc,const Object * argv)569 Object scheme::maxEx(VM* theVM, int argc, const Object* argv)
570 {
571 DeclareProcedureName("max");
572 checkArgumentLengthAtLeast(1);
573 Object maxNumber = Flonum::NEGATIVE_INF;
574 for (int i = 0; i < argc; i++) {
575 argumentCheckReal(i, number);
576 if (number.isFlonum() && (number.toFlonum())->isNan()) {
577 return number;
578 }
579 if (Arithmetic::gt(number, maxNumber)) {
580 maxNumber = number;
581 }
582 }
583 return maxNumber;
584 }
585
minEx(VM * theVM,int argc,const Object * argv)586 Object scheme::minEx(VM* theVM, int argc, const Object* argv)
587 {
588 DeclareProcedureName("min");
589 checkArgumentLengthAtLeast(1);
590 Object minNumber = Flonum::POSITIVE_INF;
591 for (int i = 0; i < argc; i++) {
592 argumentCheckReal(i, number);
593 if (number.isFlonum() && (number.toFlonum())->isNan()) {
594 return number;
595 }
596 if (Arithmetic::lt(number, minNumber)) {
597 minNumber = number;
598 }
599 }
600 return minNumber;
601 }
602
addEx(VM * theVM,int argc,const Object * argv)603 Object scheme::addEx(VM* theVM, int argc, const Object* argv)
604 {
605 DeclareProcedureName("+");
606 if (0 == argc) {
607 return Object::makeFixnum(0);
608 } else if (1 == argc) {
609 argumentCheckNumber(0, number);
610 return number;
611 }
612
613 Object ret = Object::makeFixnum(0);
614 for (int i = 0; i < argc; i++) {
615 // We don't check whether n is number or not here.
616 ret = Arithmetic::add(ret, argv[i]);
617
618 // error occured
619 if (ret.isFalse()) {
620 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(ret, argv[i]));
621 return Object::Undef;
622 }
623 }
624 return ret;
625 }
626
subEx(VM * theVM,int argc,const Object * argv)627 Object scheme::subEx(VM* theVM, int argc, const Object* argv)
628 {
629 DeclareProcedureName("-");
630 checkArgumentLengthAtLeast(1);
631
632 if (1 == argc) {
633 argumentCheckNumber(0, number);
634 return Arithmetic::mul(-1, number);
635 }
636
637 Object ret = argv[0];
638 for (int i = 1; i < argc; i++) {
639 ret = Arithmetic::sub(ret, argv[i]);
640
641 // error occured
642 if (ret.isFalse()) {
643 callWrongTypeOfArgumentViolationAfter(theVM, "-", "number", L2(ret, argv[i]));
644 return Object::Undef;
645 }
646 }
647 return ret;
648 }
649
mulEx(VM * theVM,int argc,const Object * argv)650 Object scheme::mulEx(VM* theVM, int argc, const Object* argv)
651 {
652 DeclareProcedureName("*");
653
654 if (0 == argc) {
655 return Object::makeFixnum(1);
656 } else if (1 == argc) {
657 argumentCheckNumber(0, number);
658 return number;
659 }
660
661 Object ret = Object::makeFixnum(1);
662 for (int i = 0; i < argc; i++) {
663 ret = Arithmetic::mul(ret, argv[i]);
664
665 // error occured
666 if (ret.isFalse()) {
667 callWrongTypeOfArgumentViolationAfter(theVM, "*", "number", L2(ret, argv[i]));
668 return Object::Undef;
669 }
670 }
671 return ret;
672 }
673
divideEx(VM * theVM,int argc,const Object * argv)674 Object scheme::divideEx(VM* theVM, int argc, const Object* argv)
675 {
676 DeclareProcedureName("/");
677 checkArgumentLengthAtLeast(1);
678
679 bool isDiv0Error = false;
680 if (1 == argc) {
681 argumentCheckNumber(0, number);
682 const Object ret = Arithmetic::div(Object::makeFixnum(1), number, isDiv0Error);
683 if (isDiv0Error) {
684 callAssertionViolationAfter(theVM, procedureName, "division by zero", L2(Object::makeFixnum(1), number));
685 return Object::Undef;
686 } else {
687 return ret;
688 }
689 } else {
690 Object ret = argv[0];
691 for (int i = 1; i < argc; i++) {
692 ret = Arithmetic::div(ret, argv[i], isDiv0Error);
693 if (isDiv0Error) {
694 callAssertionViolationAfter(theVM, procedureName, "division by zero", L2(ret, argv[i]));
695 return Object::Undef;
696 } else if (ret.isFalse()) {
697 callWrongTypeOfArgumentViolationAfter(theVM, "/", "number", L2(ret, argv[i]));
698 return Object::Undef;
699 }
700 }
701 return ret;
702 }
703 }
704
eqEx(VM * theVM,int argc,const Object * argv)705 Object scheme::eqEx(VM* theVM, int argc, const Object* argv)
706 {
707 DeclareProcedureName("=");
708 checkArgumentLengthAtLeast(2);
709 for (int i = 0; i < argc - 1; i++) {
710 argumentCheckNumber(i, number1);
711 argumentCheckNumber(i + 1, number2);
712 if (Arithmetic::eq(number1, number2)) {
713 continue;
714 } else {
715 return Object::False;
716 }
717 }
718 return Object::True;
719 }
720
gtEx(VM * theVM,int argc,const Object * argv)721 Object scheme::gtEx(VM* theVM, int argc, const Object* argv)
722 {
723 DeclareProcedureName(">");
724 checkArgumentLengthAtLeast(2);
725 for (int i = 0; i < argc - 1; i++) {
726 argumentCheckReal(i, number1);
727 argumentCheckReal(i + 1, number2);
728 if (Arithmetic::gt(number1, number2)) {
729 continue;
730 } else {
731 return Object::False;
732 }
733 }
734 return Object::True;
735 }
736
geEx(VM * theVM,int argc,const Object * argv)737 Object scheme::geEx(VM* theVM, int argc, const Object* argv)
738 {
739 DeclareProcedureName(">=");
740 checkArgumentLengthAtLeast(2);
741 for (int i = 0; i < argc - 1; i++) {
742 argumentCheckReal(i, number1);
743 argumentCheckReal(i + 1, number2);
744 if (Arithmetic::ge(number1, number2)) {
745 continue;
746 } else {
747 return Object::False;
748 }
749 }
750 return Object::True;
751 }
752
ltEx(VM * theVM,int argc,const Object * argv)753 Object scheme::ltEx(VM* theVM, int argc, const Object* argv)
754 {
755 DeclareProcedureName("<");
756 checkArgumentLengthAtLeast(2);
757 for (int i = 0; i < argc - 1; i++) {
758 argumentCheckReal(i, number1);
759 argumentCheckReal(i + 1, number2);
760 if (Arithmetic::lt(number1, number2)) {
761 continue;
762 } else {
763 return Object::False;
764 }
765 }
766 return Object::True;
767 }
768
leEx(VM * theVM,int argc,const Object * argv)769 Object scheme::leEx(VM* theVM, int argc, const Object* argv)
770 {
771 DeclareProcedureName("<=");
772 checkArgumentLengthAtLeast(2);
773 for (int i = 0; i < argc - 1; i++) {
774 argumentCheckReal(i, number1);
775 argumentCheckReal(i + 1, number2);
776 if (Arithmetic::le(number1, number2)) {
777 continue;
778 } else {
779 return Object::False;
780 }
781 }
782 return Object::True;
783 }
784
moduloEx(VM * theVM,int argc,const Object * argv)785 Object scheme::moduloEx(VM* theVM, int argc, const Object* argv)
786 {
787 DeclareProcedureName("modulo");
788 checkArgumentLength(2);
789 const Object x = argv[0];
790 const Object y = argv[1];
791 if (x.isFixnum()) {
792 if (0 == x.toFixnum()) {
793 return Object::makeFixnum(0);
794 } else if (y.isFixnum()) { // fixnum, fixnum
795 if (0 == y.toFixnum()) {
796 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
797 return Object::Undef;
798 }
799 intptr_t r = x.toFixnum() % y.toFixnum();
800 if (0 == r) {
801 return Object::makeFixnum(0);
802 }
803 if ((y.toFixnum() > 0) + (r > 0) == 1) {
804 r = r + y.toFixnum();
805 }
806 return Object::makeFixnum(r);
807 } else if (y.isFlonum()) { // fixnum, flonum
808 const double value = y.toFlonum()->value();
809 if (0.0 == value) {
810 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
811 return Object::Undef;
812 }
813 double r = fmod(x.toFlonum()->value(), y.toFlonum()->value());
814 if (0.0 == r) {
815 return Object::makeFlonum(0.0);
816 }
817 if ((y.toFlonum()->value() > 0.0) + (r > 0.0) == 1) {
818 r = r + y.toFixnum();
819 }
820 Flonum f(r);
821 return f.toExact();
822 } else if (y.isBignum()) { // fixnum, bignum
823 const Object modulo = Bignum::remainder(x.toFixnum(), y.toBignum());
824 if (modulo == Object::makeFixnum(0)) {
825 return modulo;
826 }
827 const bool a = Arithmetic::isNegative(y);
828 const bool b = Arithmetic::isNegative(modulo);
829 if ((a && !b) || (!a && b)) {
830 return Arithmetic::add(modulo, y);
831 }
832 return modulo;
833 } else if (y.isCompnum()) {
834 if (y.toCompnum()->isReal()) {
835 Object arguments[2];
836 arguments[0] = x;
837 arguments[1] = y.toCompnum()->real();
838 return remainderEx(theVM, 2, arguments);
839 }
840 }
841
842 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
843 return Object::Undef;
844 } else if (x.isFlonum()) {
845 if (y.isFixnum()) { // flonum, fixnum
846 if (0 == y.toFixnum()) {
847 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
848 return Object::Undef;
849 }
850
851 double r = fmod(x.toFlonum()->value(), y.toFixnum());
852 if ((y.toFixnum() > 0) + (r > 0.0) == 1) {
853 r = r + y.toFixnum();
854 }
855 if (r == 0) {
856 return Object::makeFixnum(0);
857 }
858 Flonum f(r);
859 return f.toExact();
860 } else if (y.isFlonum()) { // flonum, flonum
861 const double value = y.toFlonum()->value();
862 if (0.0 == value) {
863 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
864 return Object::Undef;
865 }
866 double r = fmod(x.toFlonum()->value(), value);
867 if (0.0 == r) {
868 return Object::makeFlonum(0.0);
869 }
870 if ((value > 0.0) + (r > 0.0) == 1) {
871 r = r + y.toFixnum();
872 }
873 Flonum f(r);
874 return f.toExact();
875 } else if (y.isBignum()) { // flonum, bignum
876 const double value = y.toBignum()->toDouble();
877 if (0.0 == value) {
878 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
879 return Object::Undef;
880 }
881 double r = fmod(x.toFlonum()->value(), value);
882 if (0.0 == r) {
883 return Object::makeFlonum(0.0);
884 }
885 if ((value > 0.0) + (r > 0.0) == 1) {
886 r = r + y.toFixnum();
887 }
888 Flonum f(r);
889 return f.toExact();
890 } else if (y.isCompnum()) { // flonum, compnum
891 if (y.toCompnum()->isReal()) {
892 Object arguments[2];
893 arguments[0] = x;
894 arguments[1] = y.toCompnum()->real();
895 return moduloEx(theVM, 2, arguments);
896 }
897 }
898
899 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
900 return Object::Undef;
901 } else if (x.isBignum()) {
902 if (y.isFixnum()) { // bignum, fixnum
903 if (0 == y.toFixnum()) {
904 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
905 return Object::Undef;
906 }
907
908 const Object modulo = Bignum::remainder(x.toBignum(), y.toFixnum());
909 if (modulo == Object::makeFixnum(0)) {
910 return modulo;
911 }
912 const bool a = Arithmetic::isNegative(y);
913 const bool b = Arithmetic::isNegative(modulo);
914 if ((a && !b) || (!a && b)) {
915 return Arithmetic::add(modulo, y);
916 }
917 return modulo;
918 } else if (y.isFlonum()) { // bignum, flonum
919 const double value = y.toFlonum()->value();
920 if (0.0 == value) {
921 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
922 return Object::Undef;
923 }
924 double r = fmod(x.toBignum()->toDouble(), value);
925 if (0.0 == r) {
926 return Object::makeFlonum(0.0);
927 }
928 if ((value > 0.0) + (r > 0.0) == 1) {
929 r = r + y.toFixnum();
930 }
931 Flonum f(r);
932 return f.toExact();
933 } else if (y.isBignum()) {
934 const Object modulo = Bignum::remainder(x.toBignum(), y.toBignum());
935 if (modulo == Object::makeFixnum(0)) {
936 return modulo;
937 }
938 const bool a = Arithmetic::isNegative(y);
939 const bool b = Arithmetic::isNegative(modulo);
940 if ((a && !b) || (!a && b)) {
941 return Arithmetic::add(modulo, y);
942 }
943 return modulo;
944 } else if (y.isCompnum()) { // bignum, compnum
945 if (y.toCompnum()->isReal()) {
946 Object arguments[2];
947 arguments[0] = x;
948 arguments[1] = y.toCompnum()->real();
949 return moduloEx(theVM, 2, arguments);
950 }
951 }
952 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
953 return Object::Undef;
954 } else if (x.isCompnum()) {
955 if (x.toCompnum()->isReal()) {
956 Object arguments[2];
957 arguments[0] = x.toCompnum()->real();
958 arguments[1] = y;
959 return moduloEx(theVM, 2, arguments);
960 }
961 }
962 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
963 return Object::Undef;
964 }
965
966 // For faster execution, we write all the code for quotient here.
quotientEx(VM * theVM,int argc,const Object * argv)967 Object scheme::quotientEx(VM* theVM, int argc, const Object* argv)
968 {
969 DeclareProcedureName("quotient");
970 checkArgumentLength(2);
971 const Object x = argv[0];
972 const Object y = argv[1];
973 if (x.isFixnum()) {
974 if (0 == x.toFixnum()) {
975 return Object::makeFixnum(0);
976 } else if (y.isFixnum()) { // fixnum, fixnum
977 if (0 == y.toFixnum()) {
978 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
979 return Object::Undef;
980 }
981 return Object::makeFixnum(x.toFixnum() / y.toFixnum());
982 } else if (y.isFlonum()) { // fixnum, flonum
983 const double value = y.toFlonum()->value();
984 if (0.0 == value) {
985 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
986 return Object::Undef;
987 }
988 Flonum f(x.toFixnum() / value);
989 return f.toExact();
990 } else if (y.isBignum()) { // fixnum, bignum
991 if (Arithmetic::eq(y, Object::makeFixnum(0))) {
992 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
993 return Object::Undef;
994 }
995 return Bignum::quotient(x.toFixnum(), y.toBignum());
996 } else if (y.isCompnum()) {
997 if (y.toCompnum()->isReal()) {
998 Object arguments[2];
999 arguments[0] = x;
1000 arguments[1] = y.toCompnum()->real();
1001 return quotientEx(theVM, 2, arguments);
1002 }
1003 }
1004
1005 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1006 return Object::Undef;
1007 } else if (x.isFlonum()) {
1008 if (y.isFixnum()) { // flonum, fixnum
1009 if (0 == y.toFixnum()) {
1010 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1011 return Object::Undef;
1012 }
1013 Flonum f(::trunc(x.toFlonum()->value() / y.toFixnum()));
1014 return f.toExact();
1015 } else if (y.isFlonum()) { // flonum, flonum
1016 const double value = y.toFlonum()->value();
1017 if (0.0 == value) {
1018 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1019 return Object::Undef;
1020 }
1021 Flonum f(::trunc(x.toFlonum()->value() / value));
1022 return f.toExact();
1023 } else if (y.isBignum()) { // flonum, bignum
1024 Flonum f(::trunc(x.toFlonum()->value() / y.toBignum()->toDouble()));
1025 return f.toExact();
1026 } else if (y.isCompnum()) { // flonum, compnum
1027 if (y.toCompnum()->isReal()) {
1028 Object arguments[2];
1029 arguments[0] = x;
1030 arguments[1] = y.toCompnum()->real();
1031 return quotientEx(theVM, 2, arguments);
1032 }
1033 }
1034
1035 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1036 return Object::Undef;
1037 } else if (x.isBignum()) {
1038 if (y.isFixnum()) { // bignum, fixnum
1039 if (0 == y.toFixnum()) {
1040 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1041 return Object::Undef;
1042 }
1043 return Bignum::quotient(x.toBignum(), y.toFixnum());
1044 } else if (y.isFlonum()) { // bignum, flonum
1045 const double value = y.toFlonum()->value();
1046 if (0.0 == value) {
1047 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1048 return Object::Undef;
1049 }
1050 Flonum f(::trunc(y.toBignum()->toDouble() / x.toFlonum()->value()));
1051 return f.toExact();
1052 } else if (y.isBignum()) {
1053 return Bignum::quotient(x.toBignum(), y.toBignum());
1054 } else if (y.isCompnum()) { // bignum, compnum
1055 if (y.toCompnum()->isReal()) {
1056 Object arguments[2];
1057 arguments[0] = x;
1058 arguments[1] = y.toCompnum()->real();
1059 return quotientEx(theVM, 2, arguments);
1060 }
1061 }
1062 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1063 return Object::Undef;
1064 } else if (x.isCompnum()) {
1065 if (x.toCompnum()->isReal()) {
1066 Object arguments[2];
1067 arguments[0] = x.toCompnum()->real();
1068 arguments[1] = y;
1069 return quotientEx(theVM, 2, arguments);
1070 }
1071 }
1072 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1073 return Object::Undef;
1074 }
1075
remainderEx(VM * theVM,int argc,const Object * argv)1076 Object scheme::remainderEx(VM* theVM, int argc, const Object* argv)
1077 {
1078 DeclareProcedureName("remainder");
1079 checkArgumentLength(2);
1080 const Object x = argv[0];
1081 const Object y = argv[1];
1082 if (x.isFixnum()) {
1083 if (0 == x.toFixnum()) {
1084 return Object::makeFixnum(0);
1085 } else if (y.isFixnum()) { // fixnum, fixnum
1086 if (0 == y.toFixnum()) {
1087 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1088 return Object::Undef;
1089 }
1090 return Object::makeFixnum(x.toFixnum() % y.toFixnum());
1091 } else if (y.isFlonum()) { // fixnum, flonum
1092 const double value = y.toFlonum()->value();
1093 if (0.0 == value) {
1094 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1095 return Object::Undef;
1096 }
1097 Flonum f(fmod(x.toFixnum(), value));
1098 return f.toExact();
1099 } else if (y.isBignum()) { // fixnum, bignum
1100 if (Arithmetic::eq(y, Object::makeFixnum(0))) {
1101 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1102 return Object::Undef;
1103 }
1104 return Bignum::remainder(x.toFixnum(), y.toBignum());
1105 } else if (y.isCompnum()) {
1106 if (y.toCompnum()->isReal()) {
1107 Object arguments[2];
1108 arguments[0] = x;
1109 arguments[1] = y.toCompnum()->real();
1110 return remainderEx(theVM, 2, arguments);
1111 }
1112 }
1113
1114 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1115 return Object::Undef;
1116 } else if (x.isFlonum()) {
1117 if (y.isFixnum()) { // flonum, fixnum
1118 if (0 == y.toFixnum()) {
1119 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1120 return Object::Undef;
1121 }
1122 Flonum f(::fmod(x.toFlonum()->value(),y.toFixnum()));
1123 return f.toExact();
1124 } else if (y.isFlonum()) { // flonum, flonum
1125 const double value = y.toFlonum()->value();
1126 if (0.0 == value) {
1127 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1128 return Object::Undef;
1129 }
1130 Flonum f(::fmod(x.toFlonum()->value(), value));
1131 return f.toExact();
1132 } else if (y.isBignum()) { // flonum, bignum
1133 Flonum f(::fmod(x.toFlonum()->value(), y.toBignum()->toDouble()));
1134 return f.toExact();
1135 } else if (y.isCompnum()) { // flonum, compnum
1136 if (y.toCompnum()->isReal()) {
1137 Object arguments[2];
1138 arguments[0] = x;
1139 arguments[1] = y.toCompnum()->real();
1140 return remainderEx(theVM, 2, arguments);
1141 }
1142 }
1143
1144 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1145 return Object::Undef;
1146 } else if (x.isBignum()) {
1147 if (y.isFixnum()) { // bignum, fixnum
1148 if (0 == y.toFixnum()) {
1149 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1150 return Object::Undef;
1151 }
1152 return Bignum::remainder(x.toBignum(), y.toFixnum());
1153 } else if (y.isFlonum()) { // bignum, flonum
1154 const double value = y.toFlonum()->value();
1155 if (0.0 == value) {
1156 callAssertionViolationAfter(theVM, procedureName, "must be non-zero", L2(x, y));
1157 return Object::Undef;
1158 }
1159 Flonum f(::fmod(y.toBignum()->toDouble(), x.toFlonum()->value()));
1160 return f.toExact();
1161 } else if (y.isBignum()) {
1162 return Bignum::remainder(x.toBignum(), y.toBignum());
1163 } else if (y.isCompnum()) { // bignum, compnum
1164 if (y.toCompnum()->isReal()) {
1165 Object arguments[2];
1166 arguments[0] = x;
1167 arguments[1] = y.toCompnum()->real();
1168 return remainderEx(theVM, 2, arguments);
1169 }
1170 }
1171 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1172 return Object::Undef;
1173 } else if (x.isCompnum()) {
1174 if (x.toCompnum()->isReal()) {
1175 Object arguments[2];
1176 arguments[0] = x.toCompnum()->real();
1177 arguments[1] = y;
1178 return remainderEx(theVM, 2, arguments);
1179 }
1180 }
1181 callWrongTypeOfArgumentViolationAfter(theVM, procedureName, "number", L2(x, y));
1182 return Object::Undef;
1183 }
1184