1 /* -*- c -*- */ 2 /**************************************************************** 3 * number 4 ****************************************************************/ 5 /*S* (number? OBJ) => BOOLEAN */ 6 /*D* Returns #t if OBJ is a number, #f otherwise */ 7 Prim(numberp, "number?", 1) 8 { 9 RETURN( SCM_MKBOOL(SCM_NUMBERP(TOS)) ); 10 } 11 /*S* (integer? OBJ) => BOOLEAN */ 12 /*D* Returns #t if OBJ is an integer number, #f otherwise */ 13 Prim(integerp, "integer?", 1) 14 { 15 if (SCM_INUMP(TOS) || SCM_BNUMP(TOS)) { RETURN(scm_true); } 16 if (SCM_FNUMP(TOS)) { 17 double x = SCM_FNUM(TOS); 18 RETURN(SCM_MKBOOL( floor(x) == x )); 19 } 20 RETURN(scm_false); 21 } 22 23 /*S* (real? OBJ) => BOOLEAN */ 24 /*D* Returns #t if OBJ is an real number, #f otherwise.*/ 25 Prim(realp, "real?", 1) 26 { 27 RETURN(SCM_MKBOOL(SCM_NUMBERP(TOS))); 28 } 29 30 /*S* (complex? OBJ) => BOOLEAN */ 31 /*D* Returns #t if OBJ is an complex number, #f otherwise.*/ 32 Prim(complexp, "complex?", 1) 33 { 34 RETURN(SCM_MKBOOL(SCM_NUMBERP(TOS))); 35 } 36 37 /*S* (rational? OBJ) => BOOLEAN */ 38 /*D* Returns #t if OBJ is an rational number, #f otherwise.*/ 39 Prim(rationalp, "rational?", 1) 40 { 41 RETURN(SCM_MKBOOL(SCM_NUMBERP(TOS))); 42 } 43 44 /*S* (exact? OBJ) => BOOLEAN */ 45 /*D* Returns #t if OBJ is an exact number, #f otherwise.*/ 46 Prim(exactp, "exact?", 1) 47 { 48 RETURN(SCM_MKBOOL( SCM_INUMP(TOS) || SCM_BNUMP(TOS) )); 49 } 50 51 /*S* (inexact? OBJ) => BOOLEAN */ 52 /*D* Returns #t if OBJ is an inexact number, #f otherwise.*/ 53 Prim(inexactp, "inexact?", 1) 54 { 55 RETURN(SCM_MKBOOL( SCM_FNUMP(TOS) )); 56 } 57 58 #ifdef INUM_OPTIMIZATION 59 #define OPTIM_LOGOP(op) \ 60 if (SCM_INUMP((long)n1 & (long)TOS)) { \ 61 if ((long)n1 op (long)TOS) { TOS=scm_true; NEXT; } TOS=scm_false; NEXT; } 62 #else 63 #define OPTIM_LOGOP(op) 64 #endif 65 66 Prim(lt2, "*i-n2<*", 2) /* n2 n1 -- flag */ 67 { 68 SOBJ n1; spop(n1); OPTIM_LOGOP(<); TOS = scm_lt2(n1, TOS); NEXT; 69 } 70 71 Prim(le2, "*i-n2<=*", 2) /* n2 n1 -- flag */ 72 { 73 SOBJ n1; spop(n1); OPTIM_LOGOP(<=); TOS = scm_le2(n1, TOS); NEXT; 74 } 75 76 Prim(ge2, "*i-n2>=*", 2) /* n2 n1 -- flag */ 77 { 78 SOBJ n1; spop(n1); OPTIM_LOGOP(>=); TOS = scm_ge2(n1, TOS); NEXT; 79 } 80 81 Prim(gt2, "*i-n2>*", 2) /* n2 n1 -- flag */ 82 { 83 SOBJ n1; spop(n1); OPTIM_LOGOP(>); TOS = scm_gt2(n1, TOS); NEXT; 84 } 85 86 Prim(eq2, "*i-n2=*", 2) 87 { 88 SOBJ n1; spop(n1); OPTIM_LOGOP(==); TOS = scm_eq2(n1, TOS); NEXT; 89 } 90 91 #define GEN_LOGOP(op) \ 92 { while((void*)(&sp[1]) < (void*)cont) { \ 93 if (!(scm_cmpnum(TOS,sp[1]) op 0)) { VRETURN(scm_false); } \ 94 sdrop(); \ 95 } \ 96 VRETURN(scm_true); \ 97 } 98 99 PrimVarargs(ltv, "*i-nv<*") 100 { 101 GEN_LOGOP(<); 102 } 103 PrimVarargs(lev, "*i-nv<=*") 104 { 105 GEN_LOGOP(<=); 106 } 107 PrimVarargs(gev, "*i-nv>=*") 108 { 109 GEN_LOGOP(>=); 110 } 111 PrimVarargs(gtv, "*i-nv>*") 112 { 113 GEN_LOGOP(>); 114 } 115 PrimVarargs(eqv, "*i-nv=*") 116 { 117 GEN_LOGOP(==); 118 } 119 120 /*S* (zero? OBJ) => BOOLEAN */ 121 /*D* Return #t if OBJ is zero, #f otherwise */ 122 Prim(zerop, "zero?", 1) 123 { 124 if (SCM_INUMP(TOS)) { RETURN(SCM_MKBOOL(SCM_INUM(TOS) == 0)); } 125 RETURN(scm_zerop(TOS)); 126 } 127 128 /*S* (positive? OBJ) => BOOLEAN */ 129 /*D* Return #t if OBJ is positive, #f otherwise */ 130 Prim(positivep, "positive?", 1) 131 { 132 if (SCM_INUMP(TOS)) { RETURN(SCM_MKBOOL(SCM_INUM(TOS) > 0)); } 133 RETURN(scm_positivep(TOS)); 134 } 135 136 /*S* (negative? OBJ) => BOOLEAN */ 137 /*D* Return #t if OBJ is negative, #f otherwise */ 138 Prim(negativep, "negative?", 1) 139 { 140 if (SCM_INUMP(TOS)) { RETURN(SCM_MKBOOL(SCM_INUM(TOS) < 0)); } 141 RETURN(scm_negativep(TOS)); 142 } 143 144 /*S* (odd? OBJ) => BOOLEAN */ 145 /*D* Return #t if OBJ is odd, #f otherwise */ 146 Prim(oddp, "odd?", 1) 147 { 148 if (SCM_INUMP(TOS)) { RETURN(SCM_MKBOOL( (SCM_INUM(TOS) & 1) == 1)); } 149 RETURN(scm_oddp(TOS)); 150 } 151 152 /*S* (even? OBJ) => BOOLEAN */ 153 /*D* Return #t if OBJ is even, #f otherwise */ 154 Prim(evenp, "even?", 1) 155 { 156 if (SCM_INUMP(TOS)) { RETURN(SCM_MKBOOL( (SCM_INUM(TOS) & 1) == 0)); } 157 RETURN(scm_evenp(TOS)); 158 } 159 160 /*S* (min X1 X2 ...) => NUMBER */ 161 /*D* Return the minimum of its arguments */ 162 PrimVarargs(min, "min") 163 { 164 if (NARGS < 1) SCM_ERR("max: wrong number of args", NULL); 165 sp++; 166 if (SCM_INUMP(TOS)) { 167 while( ((void *)sp < (void*)cont) && SCM_INUMP(*sp)) { 168 if (SCM_INUM(TOS) > SCM_INUM(*sp)) TOS = *sp; 169 sp++; 170 } 171 } 172 while((void *)sp < (void*)cont) { 173 if (scm_cmpnum(TOS, *sp) > 0) { TOS = *sp; } 174 sp++; 175 } 176 VRETURN(TOS); 177 } 178 179 /*S* (max X1 X2 ...) => NUMBER */ 180 /*D* Return the maximum of its arguments */ 181 PrimVarargs(max, "max") 182 { 183 if (NARGS < 1) SCM_ERR("max: wrong number of args", NULL); 184 sp++; 185 if (SCM_INUMP(TOS)) { 186 while( ((void *)sp < (void*)cont) && SCM_INUMP(*sp)) { 187 if (SCM_INUM(TOS) < SCM_INUM(*sp)) TOS = *sp; 188 sp++; 189 } 190 } 191 while((void *)sp < (void*)cont) { 192 if (scm_cmpnum(TOS, *sp) < 0) { TOS = *sp; } 193 sp++; 194 } 195 VRETURN(TOS); 196 } 197 198 Prim(add2, "add2", 2) /* n2 n1 -- n1+n2 */ 199 { 200 SOBJ n1; 201 spop(n1); 202 203 #ifdef INUM_OPTIMIZATION 204 if (SCM_INUMP((long)n1 & (long)TOS)) { 205 long r = SCM_INUM(n1) + SCM_INUM(TOS); 206 if (SCM_INUM_RANGE(r)) { TOS = SCM_MKINUM(r); NEXT; } 207 TOS = scm_int2bnum(r); NEXT; 208 } 209 #endif 210 TOS = scm_add2(n1, TOS); 211 NEXT; 212 } 213 214 /*S* (+ N1 ...) => NUMBER */ 215 /*D* return the sum of its arguments */ 216 PrimVarargs(addv, "addv") 217 { 218 if ((void*)sp >= (void*)cont) { VRETURN(SCM_MKINUM(0)); } 219 sp++; 220 if (SCM_INUMP(TOS)) { 221 long sum = SCM_INUM(TOS); 222 long r = 0; 223 while((void*)sp < (void*)cont && SCM_INUMP(*sp)) { 224 r = sum + SCM_INUM(*sp); 225 if (!SCM_INUM_RANGE(r)) break; 226 sum = r; 227 sp++; 228 } 229 TOS = SCM_MKINUM(sum); 230 } 231 while((void*)sp < (void*)cont) { 232 TOS = scm_add2(TOS, *sp++); 233 } 234 sp--; 235 VRETURN(TOS); 236 } 237 238 Prim(mul2, "mul2", 2) /* n2 n1 -- n1*n2 */ 239 { 240 SOBJ n1; 241 242 spop(n1); 243 244 #ifdef INUM_OPTIMIZATION 245 if (SCM_INUMP(n1) && SCM_INUMP(TOS)) { 246 long r, x, y; 247 if ( (x = SCM_INUM(n1)) == 0 || (y = SCM_INUM(TOS)) == 0) { 248 TOS = SCM_MKINUM(0); 249 NEXT; 250 } 251 r = x * y; 252 if (y == (r / x)) { 253 TOS = SCM_MKINUM(r); 254 NEXT; 255 } 256 } 257 #endif 258 TOS = scm_mul2(n1, TOS); 259 NEXT; 260 } 261 262 /*S* (* N1 ...) => NUMBER */ 263 /*D* Return the product of its arguments */ 264 PrimVarargs(mulv, "mulv") 265 { 266 if ((void*)sp >= (void*)cont) { VRETURN(SCM_MKINUM(1)); } 267 sp++; 268 if (SCM_INUMP(TOS)) { 269 long sum = SCM_INUM(TOS); 270 long r = 0; 271 long n; 272 while((void*)sp < (void*)cont && SCM_INUMP(*sp)) { 273 if ((n = SCM_INUM(*sp)) == 0) { 274 sum = 0; break; 275 } 276 r = sum * SCM_INUM(*sp); 277 if (sum != r / n) break; 278 sum = r; 279 sp++; 280 } 281 TOS = SCM_MKINUM(sum); 282 } 283 while(SCM_INUM(TOS) != 0 && (void*)sp < (void*)cont) { 284 TOS = scm_mul2(TOS, *sp++); 285 } 286 sp--; 287 VRETURN(TOS); 288 } 289 290 Prim(sub2, "sub2", 2) /* n2 n1 -- n1-n2 */ 291 { 292 SOBJ n1; 293 294 spop(n1); 295 #ifdef INUM_OPTIMIZATION 296 if (SCM_INUMP(n1) && SCM_INUMP(TOS)) { 297 long r; 298 r = SCM_INUM(n1) - SCM_INUM(TOS); 299 if (SCM_INUM_RANGE(r)) { TOS = SCM_MKINUM(r); NEXT; } 300 TOS = scm_int2bnum(r); NEXT; 301 } 302 #endif 303 TOS = scm_sub2(n1, TOS); 304 NEXT; 305 } 306 307 /*S* (- N1 ...) => NUMBER */ 308 /*D* Returns the difference of it's arguments. With one argument, 309 return the additive inverse of the argument */ 310 PrimVarargs(subv, "subv") 311 { 312 if ((void*)sp >= (void*)cont) { VRETURN(SCM_MKINUM(0)); } 313 314 if (NARGS == 1) { spush(SCM_MKINUM(0)); } 315 sp++; 316 if (SCM_INUMP(TOS)) { 317 long sum = SCM_INUM(TOS); 318 long r = 0; 319 while((void*)sp < (void*)cont && SCM_INUMP(*sp)) { 320 r = sum - SCM_INUM(*sp); 321 if (!SCM_INUM_RANGE(r)) break; 322 sum = r; 323 sp++; 324 } 325 TOS = SCM_MKINUM(sum); 326 } 327 while((void*)sp < (void*)cont) { 328 TOS = scm_sub2(TOS, *sp++); 329 } 330 VRETURN(TOS); 331 } 332 333 Prim(div2, "div2", 2) /* n2 n1 -- n1/n2 */ 334 { 335 SOBJ n1; 336 spop(n1); 337 TOS = scm_div2(n1, TOS); 338 NEXT; 339 } 340 341 /*S* (/ N1 ...) => NUMBER */ 342 /*D* Return the quotient of it's argument. With one argument, return 343 the inverse of it's argument */ 344 PrimVarargs(divv, "divv") 345 { 346 if (NARGS < 1) SCM_ERR("/: bad number of args", NULL); 347 if (NARGS == 1) spush(SCM_MKINUM(1)); 348 sp++; 349 while((void*)sp < (void*)cont) { 350 TOS = scm_div2(TOS, *sp++); 351 } 352 VRETURN(TOS); 353 } 354 355 /*S* (abs X) => NUMBER */ 356 /*D* Returns the absolute value of its argument. */ 357 Prim(abs, "abs", 1) 358 { 359 if (SCM_INUMP(TOS)) { 360 if (SCM_INUM(TOS) < 0) { TOS=SCM_MKINUM( -(SCM_INUM(TOS))); NEXT; } 361 } 362 RETURN(scm_abs(TOS)); 363 } 364 365 /*S* (quotient N1 N2) => INTEGER */ 366 /*D* Returns the quotient of N1/N2 rounded toward zero. */ 367 Prim(quotient, "quotient", 2) 368 { 369 SOBJ x; 370 spop(x); 371 RETURN(scm_quotient(x, TOS)); 372 } 373 374 /*S* (remainder N1 N2) => INTEGER */ 375 /*D* Returns the quotient of N1/N2. */ 376 Prim(remainder, "remainder", 2) 377 { 378 SOBJ x; 379 spop(x); 380 RETURN(scm_remainder(x, TOS)); 381 } 382 383 /*S* (modulo N1 N2) => NUMBER */ 384 /*D* Returns the modulo of N1/N2. */ 385 Prim(modulo, "modulo", 2) 386 { 387 SOBJ x; 388 spop(x); 389 RETURN(scm_modulo(x, TOS)); 390 } 391 392 /*S* (gcd N1 ...) => NUMBER */ 393 /*D* Return the greatest common divisor of it's arguments. */ 394 PrimVarargs(gcd, "gcd") 395 { 396 supdate(); VRETURN(scm_gcd(NARGS, sp)); 397 } 398 399 /*S* (lcm N1 ...) => NUMBER */ 400 /*D* Return the least common multiple of it's arguments */ 401 PrimVarargs(lcm, "lcm") 402 { 403 supdate(); VRETURN(scm_lcm(NARGS, sp)); 404 } 405 406 /*S* (floor N) => INTEGER */ 407 /*D* Returns the largest integer not larger than N. */ 408 Prim(floor, "floor", 1) 409 { 410 RETURN(scm_floor(TOS)); 411 } 412 413 /*S* (ceil N) => INTEGER */ 414 /*D* Returns the smallest integer not smaller than N. */ 415 Prim(ceil, "ceiling", 1) 416 { 417 RETURN(scm_ceil(TOS)); 418 } 419 420 /*S* (truncate N) => INTEGER */ 421 /*D* Returns the integer closest to N whose absolute value is not 422 larger than the absolute value of N. */ 423 Prim(truncate, "truncate", 1) 424 { 425 RETURN(scm_truncate(TOS)); 426 } 427 /*S* (round N) => INTEGER */ 428 /*D* Returns the closest integer to N, rounding to even when N is 429 halfway between two integers. */ 430 Prim(round, "round", 1) 431 { 432 RETURN(scm_round(TOS)); 433 } 434 435 /*S* (exp X) => NUMBER */ 436 /*D* Returns the value of e (the base of natural logarithms) raised to 437 the power of X. */ 438 Prim(exp, "exp", 1) 439 { 440 RETURN(scm_exp(TOS)); 441 } 442 443 /*S* (log X) => NUMBER */ 444 /*D* Returns the natural logarithm of X. */ 445 Prim(log, "log", 1) 446 { 447 RETURN(scm_log(TOS)); 448 } 449 450 /*E* (log10 X) => NUMBER */ 451 /*D* Returns the base-10 logarithm of X. */ 452 Prim(log10, "log10", 1) 453 { 454 RETURN(scm_log10(TOS)); 455 } 456 457 /*S* (sin X) => NUMBER */ 458 /*D* Returns the sine of X, where X is given in radians. */ 459 Prim(sin, "sin", 1) 460 { 461 RETURN(scm_sin(TOS)); 462 } 463 464 /*S* (cos X) => NUMBER */ 465 /*D* Returns the cosine of X, where X is given in radians. */ 466 Prim(cos, "cos", 1) 467 { 468 RETURN(scm_cos(TOS)); 469 } 470 471 /*S* (tan X) => NUMBER */ 472 /*D* Returns the tangent of X, where X is given in radians. */ 473 Prim(tan, "tan", 1) 474 { 475 RETURN(scm_tan(TOS)); 476 } 477 478 /*S* (asin X) => NUMBER */ 479 /*D* Returns the arc sine of X; that is the value whose sine is X. */ 480 Prim(asin, "asin", 1) 481 { 482 RETURN(scm_asin(TOS)); 483 } 484 485 /*S* (acos X) => NUMBER */ 486 /*D* Returns the arc cosine of X; that is the value whose sine is X. */ 487 Prim(acos, "acos", 1) 488 { 489 RETURN(scm_acos(TOS)); 490 } 491 492 /*S* (atan X) => NUMBER */ 493 /*D* Returns the arc tangent of X in radians. */ 494 /*S* (atan Y X) => NUMBER */ 495 /*D* calculates the arc tangent of the two variables X and Y. It is 496 similar to calculating the arc tangent of Y / X, except that the 497 signs of both arguments are used to determine the quadrant of the 498 result. */ 499 Prim(atan, "atan", 2) 500 { 501 SOBJ x; spop(x); RETURN(scm_atan(x, TOS)); 502 } 503 504 /*S* (sqrt X) => NUMBER */ 505 /*D* Returns the principal square root of X. */ 506 Prim(sqrt, "sqrt", 1) 507 { 508 RETURN(scm_sqrt(TOS)); 509 } 510 511 /*S* (expt X Y) => NUMBER */ 512 /*D* Returns X raised to the power Y. */ 513 Prim(expt, "expt", 2) 514 { 515 SOBJ x; spop(x); RETURN(scm_expt(x, TOS)); 516 } 517 518 /*E* (random) => FLOAT */ 519 /*D* Returns a random number in range 0-1.0. */ 520 Prim(random, "random", 0) 521 { 522 spush(scm_mkfnum(drand48())); 523 NEXT; 524 } 525 526 /*S* (exact->inexact Z) => NUMBER */ 527 /*D* Returns an inexact representation of Z. The value returned is the 528 inexact number that is numerically closest to the argument. */ 529 Prim(exact2inexact, "exact->inexact", 1) 530 { 531 RETURN(scm_exact_to_inexact(TOS)); 532 } 533 534 /*S* (inexact->exact z) => NUMBER */ 535 /*D* Returns an exact representation of Z. The value returned is the 536 exact number that is numerically closest to the argument. */ 537 Prim(inexact2exact, "inexact->exact", 1) 538 { 539 RETURN(scm_inexact_to_exact(TOS)); 540 } 541 542 /*S* (number->string Z [RADIX]) => STRING */ 543 /*D* Returns as a string an external representation of the given number 544 in the given radix */ 545 PrimVarargs(number2string, "number->string") 546 { 547 if (NARGS < 1) SCM_ERR("number->string: bad number of args", NULL); 548 VRETURN(scm_number_to_string(TOS, (NARGS > 1) ? sp[1] : NULL)); 549 } 550 551 /*S* (string->number STRING RADIX) => NUMBER */ 552 /*D* Returns a number of the maximally precise representation expressed by 553 the given string. */ 554 PrimVarargs(string2number, "string->number") 555 { 556 if (NARGS < 1) SCM_ERR("string->number: bad number of args", NULL); 557 VRETURN(scm_string_to_number(TOS, (NARGS > 1) ? sp[1] : NULL)); 558 } 559 560 /*E* (1+ X) => NUMBER*/ 561 /*D* Returns X + 1. */ 562 Prim(plus1, "1+", 1) 563 { 564 if (SCM_INUMP(TOS) && (SCM_INUM(TOS) < SOBJ_INUM_MAX)) { 565 /*(long)TOS += (1 << SOBJ_INUM_SHIFT);*/ 566 TOS = (long)TOS + (long)(1 << SOBJ_INUM_SHIFT); 567 NEXT; 568 } 569 TOS = scm_add2(SCM_MKINUM(1), TOS); 570 NEXT; 571 } 572 573 /*E* (2+ X) => NUMBER*/ 574 /*D* Returns X + 2. */ 575 Prim(plus2, "2+", 1) 576 { 577 if (SCM_INUMP(TOS) && (SCM_INUM(TOS) < SOBJ_INUM_MAX)) { 578 /*(long)TOS += (2 << SOBJ_INUM_SHIFT);*/ 579 TOS = (long)TOS + (long)(2 << SOBJ_INUM_SHIFT); 580 NEXT; 581 } 582 TOS = scm_add2(SCM_MKINUM(2), TOS); 583 NEXT; 584 } 585 586 /*E* (1- X) => NUMBER*/ 587 /*D* Returns X - 1. */ 588 Prim(minus1, "1-", 1) 589 { 590 if (SCM_INUMP(TOS) && (SCM_INUM(TOS) > SOBJ_INUM_MIN)) { 591 /*(long)TOS += (-1 << SOBJ_INUM_SHIFT);*/ 592 TOS = (long)TOS + (long)(-1 << SOBJ_INUM_SHIFT); 593 NEXT; 594 } 595 TOS = scm_sub2(TOS, SCM_MKINUM(1)); 596 NEXT; 597 } 598 599 /*E* (2- X) => NUMBER*/ 600 /*D* Returns X - 1. */ 601 Prim(minus2, "2-", 1) 602 { 603 if (SCM_INUMP(TOS) && (SCM_INUM(TOS) > SOBJ_INUM_MIN)) { 604 /*(long)TOS += (-2 << SOBJ_INUM_SHIFT);*/ 605 TOS = (long)TOS + (long)(-2 << SOBJ_INUM_SHIFT); 606 NEXT; 607 } 608 TOS = scm_sub2(TOS, SCM_MKINUM(2)); 609 NEXT; 610 } 611 612