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