1 /*-
2 * Copyright (c) 2005-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)numbers.c 2.19 11/27/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 /* Required for C99 prototypes (log2, trunc, clog10 etc)! */
34 #if !defined(_GNU_SOURCE)
35 #define _GNU_SOURCE 1
36 #endif
37
38 #include "fth.h"
39 #include "utils.h"
40
41 static FTH llong_tag;
42 static FTH float_tag;
43
44 #if HAVE_COMPLEX
45 static FTH complex_tag;
46 #endif
47
48 static FTH bignum_tag;
49 static FTH ratio_tag;
50
51 #define FTH_MATH_ERROR_THROW(Desc) \
52 fth_throw(FTH_MATH_ERROR, "%s: %s", RUNNING_WORD(), (Desc))
53
54 #define FTH_WRONG_NUMBER_TYPE(Arg, Desc) \
55 fth_throw(FTH_WRONG_TYPE_ARG, \
56 "%s: wrong number type, %s (%S), wanted %s", \
57 RUNNING_WORD(), \
58 fth_object_name(Arg), \
59 (Arg), \
60 (Desc))
61
62 static ficlFloat fth_pow(ficlFloat, ficlFloat);
63 static ficlFloat fth_floor(ficlFloat);
64 static ficlFloat fth_ceil(ficlFloat);
65 static ficlFloat fth_rint(ficlFloat);
66 static ficlFloat fth_trunc(ficlFloat);
67 static ficlFloat fth_log(ficlFloat);
68 static ficlFloat fth_log2(ficlFloat);
69 static ficlFloat fth_log10(ficlFloat);
70
71 static FTH make_object_number_type(const char *, fobj_t, int);
72 static void ficl_to_s(ficlVm *);
73
74 static FTH ll_inspect(FTH);
75 static FTH ll_to_string(FTH);
76 static FTH ll_copy(FTH);
77 static FTH ll_equal_p(FTH, FTH);
78
79 static void ficl_bignum_p(ficlVm *);
80 static void ficl_complex_p(ficlVm *);
81 static void ficl_even_p(ficlVm *);
82 static void ficl_exact_p(ficlVm *);
83 static void ficl_fixnum_p(ficlVm *);
84 static void ficl_inexact_p(ficlVm *);
85 static void ficl_integer_p(ficlVm *);
86 static void ficl_number_p(ficlVm *);
87 static void ficl_odd_p(ficlVm *);
88 static void ficl_llong_p(ficlVm *);
89 static void ficl_prime_p(ficlVm *);
90 static void ficl_ratio_p(ficlVm *);
91 static void ficl_unsigned_p(ficlVm *);
92 static void ficl_ullong_p(ficlVm *);
93
94 static void ficl_frandom(ficlVm *);
95 static void ficl_rand_seed_ref(ficlVm *);
96 static void ficl_rand_seed_set(ficlVm *);
97 static void ficl_random(ficlVm *);
98 static ficlFloat next_rand(void);
99
100 static void ficl_d_dot(ficlVm *);
101 static void ficl_d_dot_r(ficlVm *);
102 static void ficl_dot_r(ficlVm *);
103 static void ficl_u_dot_r(ficlVm *);
104 static void ficl_ud_dot(ficlVm *);
105 static void ficl_ud_dot_r(ficlVm *);
106
107 static void ficl_dabs(ficlVm *);
108 static void ficl_dmax(ficlVm *);
109 static void ficl_dmin(ficlVm *);
110 static void ficl_dnegate(ficlVm *);
111 static void ficl_dtwoslash(ficlVm *);
112 static void ficl_dtwostar(ficlVm *);
113 static void ficl_to_d(ficlVm *);
114 static void ficl_to_s(ficlVm *);
115
116 static char *format_double(char *, size_t, ficlFloat);
117 static FTH fl_inspect(FTH);
118 static FTH fl_to_string(FTH);
119 static FTH fl_copy(FTH);
120 static FTH fl_equal_p(FTH, FTH);
121
122 static void ficl_dfloats(ficlVm *);
123 static void ficl_f_dot_r(ficlVm *);
124 static void ficl_falign(ficlVm *);
125 static void ficl_falog(ficlVm *);
126 static void ficl_fexpm1(ficlVm *);
127 static void ficl_float_p(ficlVm *);
128 static void ficl_flogp1(ficlVm *);
129 static void ficl_fsincos(ficlVm *);
130 static void ficl_inf(ficlVm *);
131 static void ficl_inf_p(ficlVm *);
132 static void ficl_nan(ficlVm *);
133 static void ficl_nan_p(ficlVm *);
134 static void ficl_to_f(ficlVm *);
135 static void ficl_uf_dot_r(ficlVm *);
136
137 static void ficl_cimage(ficlVm *);
138 static void ficl_creal(ficlVm *);
139
140 #if HAVE_COMPLEX
141 static FTH cp_inspect(FTH);
142 static FTH cp_to_string(FTH);
143 static FTH cp_copy(FTH);
144 static FTH cp_equal_p(FTH, FTH);
145
146 static void ficl_c_dot(ficlVm *);
147 static void ficl_ceq(ficlVm *);
148 static void ficl_ceqz(ficlVm *);
149 static void ficl_cnoteq(ficlVm *);
150 static void ficl_cnoteqz(ficlVm *);
151 static void ficl_creciprocal(ficlVm *);
152 static void ficl_make_complex_polar(ficlVm *);
153 static void ficl_make_complex_rectangular(ficlVm *);
154 static void ficl_to_c(ficlVm *);
155 static ficlComplex make_polar(ficlFloat, ficlFloat);
156 #endif /* HAVE_COMPLEX */
157
158 static FTH bn_inspect(FTH);
159 static FTH bn_to_string(FTH);
160 static FTH bn_copy(FTH);
161 static FTH bn_equal_p(FTH, FTH);
162 static void bn_free(FTH);
163
164 static ficlBignum mpi_new(void);
165 static void mpi_free(ficlBignum);
166 static ficlBignum bn_math(FTH, FTH, int);
167 static FTH bn_add(FTH, FTH);
168 static FTH bn_sub(FTH, FTH);
169 static FTH bn_mul(FTH, FTH);
170 static FTH bn_div(FTH, FTH);
171 static void ficl_to_bn(ficlVm *);
172 static void ficl_bn_dot(ficlVm *);
173
174 static void ficl_bgcd(ficlVm *);
175 static void ficl_blcm(ficlVm *);
176 static void ficl_bpow(ficlVm *);
177 static void ficl_broot(ficlVm *);
178 static void ficl_bsqrt(ficlVm *);
179 static void ficl_bnegate(ficlVm *);
180 static void ficl_babs(ficlVm *);
181 static void ficl_bmin(ficlVm *);
182 static void ficl_bmax(ficlVm *);
183 static void ficl_btwostar(ficlVm *);
184 static void ficl_btwoslash(ficlVm *);
185 static void ficl_bmod(ficlVm *);
186 static void ficl_bslashmod(ficlVm *);
187 static void ficl_blshift(ficlVm *);
188 static void ficl_brshift(ficlVm *);
189
190 static FTH rt_inspect(FTH);
191 static FTH rt_to_string(FTH);
192 static FTH rt_copy(FTH);
193 static FTH rt_equal_p(FTH, FTH);
194 static void rt_free(FTH);
195
196 static ficlRatio mpr_new(void);
197 static void mpr_free(ficlRatio);
198 static FTH make_rational(ficlBignum, ficlBignum);
199 static void ficl_to_rt(ficlVm *);
200 static void ficl_q_dot(ficlVm *);
201 static void ficl_qnegate(ficlVm *);
202 static void ficl_qfloor(ficlVm *);
203 static void ficl_qceil(ficlVm *);
204 static void ficl_qabs(ficlVm *);
205 static void ficl_qinvert(ficlVm *);
206 static ficlRatio rt_math(FTH, FTH, int);
207 static FTH rt_add(FTH, FTH);
208 static FTH rt_sub(FTH, FTH);
209 static FTH rt_mul(FTH, FTH);
210 static FTH rt_div(FTH, FTH);
211 static FTH number_floor(FTH);
212 static FTH number_inv(FTH);
213 static void ficl_rationalize(ficlVm *);
214
215 static void ficl_fegetround(ficlVm *);
216 static void ficl_fesetround(ficlVm *);
217
218 #define NUMB_FIXNUM_P(Obj) (IMMEDIATE_P(Obj) && FIXNUM_P(Obj))
219 #define FTH_FLOAT_REF_INT(Obj) FTH_ROUND(FTH_FLOAT_OBJECT(Obj))
220
221 #if HAVE_COMPLEX
222 #define FTH_COMPLEX_REAL(Obj) creal(FTH_COMPLEX_OBJECT(Obj))
223 #define FTH_COMPLEX_IMAG(Obj) cimag(FTH_COMPLEX_OBJECT(Obj))
224
225 ficlComplex
ficlStackPopComplex(ficlStack * stack)226 ficlStackPopComplex(ficlStack *stack)
227 {
228 ficlComplex cp;
229
230 cp = fth_complex_ref(ficl_to_fth(STACK_FTH_REF(stack)));
231 stack->top--;
232 return (cp);
233 }
234
235 void
ficlStackPushComplex(ficlStack * stack,ficlComplex cp)236 ficlStackPushComplex(ficlStack *stack, ficlComplex cp)
237 {
238 FTH fp;
239
240 fp = fth_make_complex(cp);
241 ++stack->top;
242 STACK_FTH_SET(stack, fp);
243 }
244 #else /* !HAVE_COMPLEX */
245 #define FTH_COMPLEX_REAL(Obj) fth_real_ref(Obj)
246 #define FTH_COMPLEX_IMAG(Obj) 0.0
247 #endif /* HAVE_COMPLEX */
248
249 #define FTH_BIGNUM_REF_INT(Obj) mpi_geti(FTH_BIGNUM_OBJECT(Obj))
250 #define FTH_BIGNUM_REF_UINT(Obj) (unsigned long)mpi_geti(FTH_BIGNUM_OBJECT(Obj))
251 #define FTH_BIGNUM_REF_FLOAT(Obj) mpi_getd(FTH_BIGNUM_OBJECT(Obj))
252 #define FTH_RATIO_REF_INT(Obj) (long)mpr_getd(FTH_RATIO_OBJECT(Obj))
253 #define FTH_RATIO_REF_FLOAT(Obj) mpr_getd(FTH_RATIO_OBJECT(Obj))
254
255 /*
256 * Don't forget mpi_free(bn)!
257 */
258 ficlBignum
ficlStackPopBignum(ficlStack * stack)259 ficlStackPopBignum(ficlStack *stack)
260 {
261 ficlBignum bn;
262
263 bn = fth_bignum_ref(ficl_to_fth(STACK_FTH_REF(stack)));
264 stack->top--;
265 return (bn);
266 }
267
268 void
ficlStackPushBignum(ficlStack * stack,ficlBignum bn)269 ficlStackPushBignum(ficlStack *stack, ficlBignum bn)
270 {
271 FTH fp;
272
273 fp = fth_make_bignum(bn);
274 ++stack->top;
275 STACK_FTH_SET(stack, fp);
276 }
277
278 /*
279 * Don't forget mpr_free(rt)!
280 */
281 ficlRatio
ficlStackPopRatio(ficlStack * stack)282 ficlStackPopRatio(ficlStack *stack)
283 {
284 ficlRatio rt;
285
286 rt = fth_ratio_ref(ficl_to_fth(STACK_FTH_REF(stack)));
287 stack->top--;
288 return (rt);
289 }
290
291 void
ficlStackPushRatio(ficlStack * stack,ficlRatio rt)292 ficlStackPushRatio(ficlStack *stack, ficlRatio rt)
293 {
294 FTH fp;
295
296 fp = fth_make_rational(rt);
297 ++stack->top;
298 STACK_FTH_SET(stack, fp);
299 }
300
301 static FTH
make_object_number_type(const char * name,fobj_t type,int flags)302 make_object_number_type(const char *name, fobj_t type, int flags)
303 {
304 FTH new;
305
306 new = make_object_type(name, type);
307 FTH_OBJECT_FLAG(new) = N_NUMBER_T | flags;
308 return (new);
309 }
310
311 #if defined(HAVE_POW)
312 #define FTH_POW(x, y) pow(x, y)
313 #else
314 #define FTH_POW(x, y) FTH_NOT_IMPLEMENTED(pow)
315 #endif
316
317 static ficlFloat
fth_pow(ficlFloat x,ficlFloat y)318 fth_pow(ficlFloat x, ficlFloat y)
319 {
320 return (FTH_POW(x, y));
321 }
322
323 #if defined(HAVE_FLOOR)
324 #define FTH_FLOOR(r) floor(r)
325 #else
326 #define FTH_FLOOR(r) ((ficlFloat)((ficlInteger)(r)))
327 #endif
328
329 static ficlFloat
fth_floor(ficlFloat x)330 fth_floor(ficlFloat x)
331 {
332 return (FTH_FLOOR(x));
333 }
334
335 #if defined(HAVE_CEIL)
336 #define FTH_CEIL(r) ceil(r)
337 #else
338 #define FTH_CEIL(r) ((ficlFloat)((ficlInteger)((r) + 1.0)))
339 #endif
340
341 static ficlFloat
fth_ceil(ficlFloat x)342 fth_ceil(ficlFloat x)
343 {
344 return (FTH_CEIL(x));
345 }
346
347 #if defined(HAVE_RINT)
348 #define FTH_ROUND(r) rint(r)
349 #else
350 #define FTH_ROUND(r) fth_rint(r)
351 #endif
352
353 static ficlFloat
fth_rint(ficlFloat x)354 fth_rint(ficlFloat x)
355 {
356 #if defined(HAVE_RINT)
357 return (rint(x));
358 #else
359 if (x != FTH_FLOOR(x)) {
360 ficlFloat half, half2, res;
361
362 half = x + 0.5;
363 half2 = half * 0.5;
364 res = FTH_FLOOR(half);
365
366 if (half == res && half2 != FTH_FLOOR(half2))
367 return (res - 1.0);
368
369 return (res);
370 }
371 return (x);
372 #endif
373 }
374
375 #if defined(HAVE_TRUNC)
376 #define FTH_TRUNC(r) trunc(r)
377 #else
378 #define FTH_TRUNC(r) (((r) < 0.0) ? -FTH_FLOOR(-(r)) : FTH_FLOOR(r))
379 #endif
380
381 static ficlFloat
fth_trunc(ficlFloat x)382 fth_trunc(ficlFloat x)
383 {
384 return (FTH_TRUNC(x));
385 }
386
387 #if defined(INFINITY)
388 #define FTH_INF (ficlFloat)INFINITY
389 #else
390 static ficlFloat fth_infinity;
391 #define FTH_INF fth_infinity
392 #endif
393
394 #if defined(NAN)
395 #define FTH_NAN (ficlFloat)NAN
396 #else
397 #define FTH_NAN sqrt(-1.0)
398 #endif
399
400 int
fth_isinf(ficlFloat x)401 fth_isinf(ficlFloat x)
402 {
403 #if defined(HAVE_DECL_ISINF)
404 return (isinf(x));
405 #else
406 return (0);
407 #endif
408 }
409
410 int
fth_isnan(ficlFloat x)411 fth_isnan(ficlFloat x)
412 {
413 #if defined(HAVE_DECL_ISNAN)
414 return ((int) isnan(x));
415 #else
416 return (x == sqrt(-1.0)); /* NaN */
417 #endif
418 }
419
420 #if defined(HAVE_LOG2)
421 #define FTH_LOG2(r) log2(r)
422 #else
423 #define FTH_LOG2(r) (log10(r) / log10(2.0))
424 #endif
425
426 static ficlFloat
fth_log(ficlFloat x)427 fth_log(ficlFloat x)
428 {
429 if (x >= 0.0)
430 return (log(x));
431 FTH_MATH_ERROR_THROW("log, x < 0");
432 /* NOTREACHED */
433 return (0.0);
434 }
435
436 static ficlFloat
fth_log2(ficlFloat x)437 fth_log2(ficlFloat x)
438 {
439 if (x >= 0.0)
440 return (FTH_LOG2(x));
441 FTH_MATH_ERROR_THROW("log2, x < 0");
442 /* NOTREACHED */
443 return (0.0);
444 }
445
446 static ficlFloat
fth_log10(ficlFloat x)447 fth_log10(ficlFloat x)
448 {
449 if (x >= 0.0)
450 return (log10(x));
451 FTH_MATH_ERROR_THROW("log10, x < 0");
452 /* NOTREACHED */
453 return (0.0);
454 }
455
456 /*
457 * Minix seems to lack asinh, acosh, atanh.
458 */
459 #if !defined(HAVE_ASINH)
460 ficlFloat
asinh(ficlFloat x)461 asinh(ficlFloat x)
462 {
463 return (log(x + sqrt(x * x + 1.0)));
464 }
465 #endif
466
467 #if !defined(HAVE_ACOSH)
468 ficlFloat
acosh(ficlFloat x)469 acosh(ficlFloat x)
470 {
471 return (log(x + sqrt(x * x - 1.0)));
472 }
473 #endif
474
475 #if !defined(HAVE_ATANH)
476 ficlFloat
atanh(ficlFloat x)477 atanh(ficlFloat x)
478 {
479 /* from freebsd (/usr/src/lib/msun/src/e_atanh.c) */
480 if (fabs(x) > 1.0)
481 return (FTH_NAN);
482
483 if (fabs(x) == 1.0)
484 return (FTH_INF);
485
486 if (fth_isnan(x))
487 return (FTH_NAN);
488
489 return (log((1.0 + x) / (1.0 - x)) * 0.5);
490 }
491 #endif
492
493 /* === Begin of missing complex functions. === */
494
495 #if HAVE_COMPLEX
496
497 /*
498 * Some libc/libm do provide them, but others do not (like FreeBSD).
499 */
500
501 /* Trigonometric functions. */
502
503 #if !defined(HAVE_CSIN)
504 ficlComplex
csin(ficlComplex z)505 csin(ficlComplex z)
506 {
507 return (sin(creal(z)) * cosh(cimag(z)) +
508 (cos(creal(z)) * sinh(cimag(z))) * _Complex_I);
509 }
510 #endif
511
512 #if !defined(HAVE_CCOS)
513 ficlComplex
ccos(ficlComplex z)514 ccos(ficlComplex z)
515 {
516 return (cos(creal(z)) * cosh(cimag(z)) +
517 (-sin(creal(z)) * sinh(cimag(z))) * _Complex_I);
518 }
519 #endif
520
521 #if !defined(HAVE_CTAN)
522 ficlComplex
ctan(ficlComplex z)523 ctan(ficlComplex z)
524 {
525 return (csin(z) / ccos(z));
526 }
527 #endif
528
529 #if !defined(HAVE_CASIN)
530 ficlComplex
casin(ficlComplex z)531 casin(ficlComplex z)
532 {
533 return (-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z)));
534 }
535 #endif
536
537 #if !defined(HAVE_CACOS)
538 ficlComplex
cacos(ficlComplex z)539 cacos(ficlComplex z)
540 {
541 return (-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z)));
542 }
543 #endif
544
545 #if !defined(HAVE_CATAN)
546 ficlComplex
catan(ficlComplex z)547 catan(ficlComplex z)
548 {
549 return (_Complex_I *
550 clog((_Complex_I + z) / (_Complex_I - z)) / 2.0);
551 }
552 #endif
553
554 #if !defined(HAVE_CATAN2)
555 ficlComplex
catan2(ficlComplex z,ficlComplex x)556 catan2(ficlComplex z, ficlComplex x)
557 {
558 return (-_Complex_I *
559 clog((x + _Complex_I * z) / csqrt(x * x + z * z)));
560 }
561 #endif
562
563 /* Hyperbolic functions. */
564
565 #if !defined(HAVE_CSINH)
566 ficlComplex
csinh(ficlComplex z)567 csinh(ficlComplex z)
568 {
569 return (sinh(creal(z)) * cos(cimag(z)) +
570 (cosh(creal(z)) * sin(cimag(z))) * _Complex_I);
571 }
572 #endif
573
574 #if !defined(HAVE_CCOSH)
575 ficlComplex
ccosh(ficlComplex z)576 ccosh(ficlComplex z)
577 {
578 return (cosh(creal(z)) * cos(cimag(z)) +
579 (sinh(creal(z)) * sin(cimag(z))) * _Complex_I);
580 }
581 #endif
582
583 #if !defined(HAVE_CTANH)
584 ficlComplex
ctanh(ficlComplex z)585 ctanh(ficlComplex z)
586 {
587 return (csinh(z) / ccosh(z));
588 }
589 #endif
590
591 #if !defined(HAVE_CASINH)
592 ficlComplex
casinh(ficlComplex z)593 casinh(ficlComplex z)
594 {
595 return (clog(z + csqrt(1.0 + z * z)));
596 }
597 #endif
598
599 #if !defined(HAVE_CACOSH)
600 ficlComplex
cacosh(ficlComplex z)601 cacosh(ficlComplex z)
602 {
603 return (clog(z + csqrt(z * z - 1.0)));
604 }
605 #endif
606
607 #if !defined(HAVE_CATANH)
608 ficlComplex
catanh(ficlComplex z)609 catanh(ficlComplex z)
610 {
611 return (clog((1.0 + z) / (1.0 - z)) / 2.0);
612 }
613 #endif
614
615 /* Exponential and logarithmic functions. */
616
617 #if !defined(HAVE_CEXP)
618 ficlComplex
cexp(ficlComplex z)619 cexp(ficlComplex z)
620 {
621 return (exp(creal(z)) * cos(cimag(z)) +
622 (exp(creal(z)) * sin(cimag(z))) * _Complex_I);
623 }
624 #endif
625
626 #if !defined(HAVE_CLOG)
627 ficlComplex
clog(ficlComplex z)628 clog(ficlComplex z)
629 {
630 return (log(fabs(cabs(z))) + carg(z) * _Complex_I);
631 }
632 #endif
633
634 #if !defined(HAVE_CLOG10)
635 ficlComplex
clog10(ficlComplex z)636 clog10(ficlComplex z)
637 {
638 return (clog(z) / log(10));
639 }
640 #endif
641
642 /* Power functions. */
643
644 #if !defined(HAVE_CPOW)
645 ficlComplex
cpow(ficlComplex a,ficlComplex z)646 cpow(ficlComplex a, ficlComplex z)
647 {
648 /* from netbsd (/usr/src/lib/libm/complex/cpow.c) */
649 double x, y, r, theta, absa, arga;
650
651 x = creal(z);
652 y = cimag(z);
653 absa = cabs(a);
654
655 if (absa == 0.0)
656 return (0.0 + 0.0 * _Complex_I);
657
658 arga = carg(a);
659 r = FTH_POW(absa, x);
660 theta = x * arga;
661
662 if (y != 0.0) {
663 r = r * exp(-y * arga);
664 theta = theta + y * log(absa);
665 }
666 return (r * cos(theta) + (r * sin(theta)) * _Complex_I);
667 }
668 #endif
669
670 #if !defined(HAVE_CSQRT)
671 ficlComplex
csqrt(ficlComplex z)672 csqrt(ficlComplex z)
673 {
674 ficlFloat r, x;
675
676 if (cimag(z) < 0.0)
677 return (conj(csqrt(conj(z))));
678
679 r = cabs(z);
680 x = creal(z);
681 return (sqrt((r + x) / 2.0) + sqrt((r - x) / 2.0) * _Complex_I);
682 }
683 #endif
684
685 /* Absolute value and conjugates. */
686
687 #if !defined(HAVE_CABS)
688 ficlFloat
cabs(ficlComplex z)689 cabs(ficlComplex z)
690 {
691 return (hypot(creal(z), cimag(z)));
692 }
693 #endif
694
695 #if !defined(HAVE_CABS2)
696 ficlFloat
cabs2(ficlComplex z)697 cabs2(ficlComplex z)
698 {
699 return (creal(z) * creal(z) + cimag(z) * cimag(z));
700 }
701 #endif
702
703 #if !defined(HAVE_CARG)
704 ficlFloat
carg(ficlComplex z)705 carg(ficlComplex z)
706 {
707 return (atan2(cimag(z), creal(z)));
708 }
709 #endif
710
711 #if !defined(HAVE_CONJ)
712 ficlComplex
conj(ficlComplex z)713 conj(ficlComplex z)
714 {
715 return (~z);
716 }
717 #endif
718 #endif /* HAVE_COMPLEX */
719
720 /* End of missing complex functions. */
721
722 /*
723 * ficlFloat
724 * ficlComplex
725 */
726 #define N_FUNC_ONE_ARG(Name, CName, Type) \
727 static void \
728 ficl_ ## Name(ficlVm *vm) \
729 { \
730 ficl ## Type x; \
731 \
732 FTH_STACK_CHECK(vm, 1, 1); \
733 x = ficlStackPop ## Type(vm->dataStack); \
734 ficlStackPush ## Type(vm->dataStack, CName(x)); \
735 } \
736 static char* h_ ## Name = "( x -- y ) y = " #CName "(x)"
737
738 /*
739 * ficlFloat
740 * ficlComplex
741 */
742 #define N_FUNC_TWO_ARGS(Name, CName, Type) \
743 static void \
744 ficl_ ## Name(ficlVm *vm) \
745 { \
746 ficl ## Type x; \
747 ficl ## Type y; \
748 \
749 FTH_STACK_CHECK(vm, 2, 1); \
750 y = ficlStackPop ## Type(vm->dataStack); \
751 x = ficlStackPop ## Type(vm->dataStack); \
752 ficlStackPush ## Type(vm->dataStack, CName(x, y)); \
753 } \
754 static char* h_ ## Name = "( x y -- z ) z = " #CName "(x, y)"
755
756 /*
757 * ficl2Integer
758 * ficlComplex
759 */
760 #define N_FUNC_TWO_ARGS_OP(Name, OP, Type) \
761 static void \
762 ficl_ ## Name(ficlVm *vm) \
763 { \
764 ficl ## Type x; \
765 ficl ## Type y; \
766 \
767 FTH_STACK_CHECK(vm, 2, 1); \
768 y = ficlStackPop ## Type(vm->dataStack); \
769 x = ficlStackPop ## Type(vm->dataStack); \
770 ficlStackPush ## Type(vm->dataStack, x OP y); \
771 } \
772 static char* h_ ## Name = "( x y -- z ) z = x " #OP " y"
773
774 /*
775 * ficl2Integer
776 */
777 #define N_FUNC_TEST_ZERO(Name, OP, Type) \
778 static void \
779 ficl_ ## Name(ficlVm *vm) \
780 { \
781 ficl ## Type x; \
782 \
783 FTH_STACK_CHECK(vm, 1, 1); \
784 x = ficlStackPop ## Type(vm->dataStack); \
785 ficlStackPushBoolean(vm->dataStack, (x OP 0)); \
786 } \
787 static char* h_ ## Name = "( x -- f ) x " #OP " 0 => flag"
788
789 /*
790 * ficlUnsigned
791 * ficl2Integer
792 * ficl2Unsigned
793 */
794 #define N_FUNC_TEST_TWO_OP(Name, OP, Type) \
795 static void \
796 ficl_ ## Name(ficlVm *vm) \
797 { \
798 ficl ## Type x; \
799 ficl ## Type y; \
800 \
801 FTH_STACK_CHECK(vm, 2, 1); \
802 y = ficlStackPop ## Type(vm->dataStack); \
803 x = ficlStackPop ## Type(vm->dataStack); \
804 ficlStackPushBoolean(vm->dataStack, (x OP y)); \
805 } \
806 static char* h_ ## Name = "( x y -- f ) x " #OP " y => flag"
807
808 static void
ficl_to_s(ficlVm * vm)809 ficl_to_s(ficlVm *vm)
810 {
811 #define h_to_s "( x -- y ) Convert any number X to ficlInteger"
812 FTH n;
813
814 FTH_STACK_CHECK(vm, 1, 1);
815 n = fth_pop_ficl_cell(vm);
816 ficlStackPushInteger(vm->dataStack, fth_int_ref(n));
817 }
818
819 static void
ficl_to_d(ficlVm * vm)820 ficl_to_d(ficlVm *vm)
821 {
822 #define h_to_d "( x -- d ) Convert any number X to ficl2Integer"
823 ficl2Integer d;
824
825 FTH_STACK_CHECK(vm, 1, 1);
826 d = ficlStackPop2Integer(vm->dataStack);
827 ficlStackPushFTH(vm->dataStack, fth_make_llong(d));
828 }
829
830 static void
ficl_to_ud(ficlVm * vm)831 ficl_to_ud(ficlVm *vm)
832 {
833 #define h_to_ud "( x -- ud ) Convert any number X to ficl2Unsigned"
834 ficl2Unsigned ud;
835
836 FTH_STACK_CHECK(vm, 1, 1);
837 ud = ficlStackPop2Unsigned(vm->dataStack);
838 ficlStackPushFTH(vm->dataStack, fth_make_ullong(ud));
839 }
840
841 static void
ficl_to_f(ficlVm * vm)842 ficl_to_f(ficlVm *vm)
843 {
844 #define h_to_f "( x -- y ) Convert any number X to ficlFloat"
845 ficlFloat f;
846
847 FTH_STACK_CHECK(vm, 1, 1);
848 f = ficlStackPopFloat(vm->dataStack);
849 ficlStackPushFloat(vm->dataStack, f);
850 }
851
852 #if HAVE_COMPLEX
853 static void
ficl_to_c(ficlVm * vm)854 ficl_to_c(ficlVm *vm)
855 {
856 #define h_to_c "( x -- y ) Convert any number X to ficlComplex"
857 ficlComplex cp;
858
859 FTH_STACK_CHECK(vm, 1, 1);
860 cp = ficlStackPopComplex(vm->dataStack);
861 ficlStackPushComplex(vm->dataStack, cp);
862 }
863 #endif
864
865 static void
ficl_to_bn(ficlVm * vm)866 ficl_to_bn(ficlVm *vm)
867 {
868 #define h_to_bn "( x -- y ) Convert any number X to ficlBignum"
869 ficlBignum bn;
870
871 FTH_STACK_CHECK(vm, 1, 1);
872 bn = ficlStackPopBignum(vm->dataStack);
873 ficlStackPushBignum(vm->dataStack, bn);
874 }
875
876 static void
ficl_to_rt(ficlVm * vm)877 ficl_to_rt(ficlVm *vm)
878 {
879 #define h_to_rt "( x -- y ) Convert any number X to ficlRatio"
880 ficlRatio rt;
881
882 FTH_STACK_CHECK(vm, 1, 1);
883 rt = ficlStackPopRatio(vm->dataStack);
884 ficlStackPushRatio(vm->dataStack, rt);
885 }
886
887 /* === LONG-LONG === */
888
889 #define h_list_of_llong_functions "\
890 *** NUMBER PRIMITIVES ***\n\
891 number? fixnum? unsigned?\n\
892 long-long? ulong-long?\n\
893 integer? exact? inexact?\n\
894 make-long-long make-ulong-long\n\
895 rand-seed-ref rand-seed-set!\n\
896 random frandom\n\
897 .r u.r d. ud. d.r ud.r\n\
898 u= u<> u< u> u<= u>=\n\
899 s>d s>ud d>s f>d f>ud d>f\n\
900 d0= (dzero?) d0<> d0< (dnegative?) d0> d0<= d0>= (dpositive?)\n\
901 d= d<> d< d> d<= d>=\n\
902 du= du<> du< du> du<= du>=\n\
903 d+ d- d* d/\n\
904 dnegate dabs dmin dmax d2* d2/"
905
906 static FTH
ll_inspect(FTH self)907 ll_inspect(FTH self)
908 {
909 return (fth_make_string_format("%s: %lld",
910 FTH_INSTANCE_NAME(self), FTH_LONG_OBJECT(self)));
911 }
912
913 static FTH
ll_to_string(FTH self)914 ll_to_string(FTH self)
915 {
916 return (fth_make_string_format("%lld", FTH_LONG_OBJECT(self)));
917 }
918
919 static FTH
ll_copy(FTH self)920 ll_copy(FTH self)
921 {
922 return (fth_make_llong(FTH_LONG_OBJECT(self)));
923 }
924
925 static FTH
ll_equal_p(FTH self,FTH obj)926 ll_equal_p(FTH self, FTH obj)
927 {
928 return (BOOL_TO_FTH(FTH_LONG_OBJECT(self) == FTH_LONG_OBJECT(obj)));
929 }
930
931 FTH
fth_make_llong(ficl2Integer d)932 fth_make_llong(ficl2Integer d)
933 {
934 FTH self;
935
936 self = fth_make_instance(llong_tag, NULL);
937 FTH_LONG_OBJECT_SET(self, d);
938 return (self);
939 }
940
941 FTH
fth_make_ullong(ficl2Unsigned ud)942 fth_make_ullong(ficl2Unsigned ud)
943 {
944 FTH self;
945
946 self = fth_make_instance(llong_tag, NULL);
947 FTH_ULONG_OBJECT_SET(self, ud);
948 return (self);
949 }
950
951 FTH
fth_llong_copy(FTH obj)952 fth_llong_copy(FTH obj)
953 {
954 if (FTH_LLONG_P(obj))
955 return (ll_copy(obj));
956 return (obj);
957 }
958
959 int
fth_fixnum_p(FTH obj)960 fth_fixnum_p(FTH obj)
961 {
962 return (NUMB_FIXNUM_P(obj));
963 }
964
965 int
fth_number_p(FTH obj)966 fth_number_p(FTH obj)
967 {
968 return (NUMB_FIXNUM_P(obj) || FTH_NUMBER_T_P(obj));
969 }
970
971 int
fth_exact_p(FTH obj)972 fth_exact_p(FTH obj)
973 {
974 return (NUMB_FIXNUM_P(obj) || FTH_EXACT_T_P(obj));
975 }
976
977 int
fth_integer_p(FTH obj)978 fth_integer_p(FTH obj)
979 {
980 return (NUMB_FIXNUM_P(obj) || FTH_LLONG_P(obj));
981 }
982
983 int
fth_char_p(FTH obj)984 fth_char_p(FTH obj)
985 {
986 return (NUMB_FIXNUM_P(obj) && isprint((int) FIX_TO_INT(obj)));
987 }
988
989 int
fth_unsigned_p(FTH obj)990 fth_unsigned_p(FTH obj)
991 {
992 return (fth_integer_p(obj) && fth_long_long_ref(obj) >= 0);
993 }
994
995 int
fth_ullong_p(FTH obj)996 fth_ullong_p(FTH obj)
997 {
998 return (FTH_LLONG_P(obj) && FTH_LONG_OBJECT(obj) >= 0);
999 }
1000
1001 static void
ficl_number_p(ficlVm * vm)1002 ficl_number_p(ficlVm *vm)
1003 {
1004 #define h_number_p "( obj -- f ) test if OBJ is a number\n\
1005 nil number? => #f\n\
1006 0 number? => #t\n\
1007 0i number? => #t\n\
1008 Return #t if OBJ is a number (ficlInteger, ficl2Integer, ficlFloat, \
1009 ficlComplex, ficlBignum, ficlRatio), otherwise #f."
1010 FTH obj;
1011
1012 FTH_STACK_CHECK(vm, 1, 1);
1013 obj = fth_pop_ficl_cell(vm);
1014 ficlStackPushBoolean(vm->dataStack, FTH_NUMBER_P(obj));
1015 }
1016
1017 static void
ficl_fixnum_p(ficlVm * vm)1018 ficl_fixnum_p(ficlVm *vm)
1019 {
1020 #define h_fixnum_p "( obj -- f ) test if OBJ is fixnum\n\
1021 nil fixnum? => #f\n\
1022 0 fixnum? => #t\n\
1023 0x3fffffff fixnum? => #t\n\
1024 0x3fffffff 1+ fixnum? => #f\n\
1025 Return #t if OBJ is fixnum (ficlInteger/ficlUnsigned), otherwise #f."
1026 FTH obj;
1027
1028 FTH_STACK_CHECK(vm, 1, 1);
1029 obj = fth_pop_ficl_cell(vm);
1030 ficlStackPushBoolean(vm->dataStack, NUMB_FIXNUM_P(obj));
1031 }
1032
1033 static void
ficl_unsigned_p(ficlVm * vm)1034 ficl_unsigned_p(ficlVm *vm)
1035 {
1036 #define h_unsigned_p "( obj -- f ) test if OBJ is unsigned integer\n\
1037 nil unsigned? => #f\n\
1038 -1 unsigned? => #f\n\
1039 0 unsigned? => #t\n\
1040 0xffffffffffff unsigned? => #t\n\
1041 Return #t if OBJ is unsigned integer (ficlUnsigned, \
1042 ficl2Unsigned, ficlBignum), otherwise #f."
1043 FTH obj;
1044 int flag;
1045
1046 FTH_STACK_CHECK(vm, 1, 1);
1047 obj = fth_pop_ficl_cell(vm);
1048
1049 if (FTH_UNSIGNED_P(obj))
1050 flag = 1;
1051 else if (FTH_BIGNUM_P(obj))
1052 flag = (mpi_sgn(FTH_BIGNUM_OBJECT(obj)) >= 0);
1053 else
1054 flag = 0;
1055
1056 ficlStackPushBoolean(vm->dataStack, flag);
1057 }
1058
1059 static void
ficl_llong_p(ficlVm * vm)1060 ficl_llong_p(ficlVm *vm)
1061 {
1062 #define h_llong_p "( obj -- f ) test if OBJ is long-long integer\n\
1063 nil long-long? => #f\n\
1064 -1 long-long? => #f\n\
1065 -1 make-long-long long-long? => #t\n\
1066 Return #t if OBJ is long-long object (ficl2Integer/ficl2Unsigned), \
1067 otherwise #f."
1068 FTH obj;
1069
1070 FTH_STACK_CHECK(vm, 1, 1);
1071 obj = fth_pop_ficl_cell(vm);
1072 ficlStackPushBoolean(vm->dataStack, FTH_LLONG_P(obj));
1073 }
1074
1075 static void
ficl_ullong_p(ficlVm * vm)1076 ficl_ullong_p(ficlVm *vm)
1077 {
1078 #define h_ullong_p "( obj -- f ) test if OBJ is unsigned long-long integer\n\
1079 nil ulong-long? => #f\n\
1080 1 ulong-long? => #f\n\
1081 1 make-ulong-long ulong-long? => #t\n\
1082 Return #t if OBJ is ulong-long object (ficl2Unsigned), otherwise #f."
1083 FTH obj;
1084
1085 FTH_STACK_CHECK(vm, 1, 1);
1086 obj = fth_pop_ficl_cell(vm);
1087 ficlStackPushBoolean(vm->dataStack, FTH_ULLONG_P(obj));
1088 }
1089
1090 static void
ficl_integer_p(ficlVm * vm)1091 ficl_integer_p(ficlVm *vm)
1092 {
1093 #define h_integer_p "( obj -- f ) test if OBJ is an integer\n\
1094 nil integer? => #f\n\
1095 1.0 integer? => #f\n\
1096 -1 integer? => #t\n\
1097 1 make-long-long integer? => #t\n\
1098 12345678901234567890 integer? => #t\n\
1099 Return #t if OBJ is an integer (ficlInteger, ficl2Integer, or ficlBignum), \
1100 otherwise #f."
1101 FTH obj;
1102 int flag;
1103
1104 FTH_STACK_CHECK(vm, 1, 1);
1105 obj = fth_pop_ficl_cell(vm);
1106 flag = FTH_INTEGER_P(obj) || FTH_BIGNUM_P(obj);
1107 ficlStackPushBoolean(vm->dataStack, flag);
1108 }
1109
1110 static void
ficl_exact_p(ficlVm * vm)1111 ficl_exact_p(ficlVm *vm)
1112 {
1113 #define h_exact_p "( obj -- f ) test if OBJ is an exact number\n\
1114 1 exact? => #t\n\
1115 1/2 exact? => #t\n\
1116 1.0 exact? => #f\n\
1117 1i exact? => #f\n\
1118 Return #t if OBJ is an exact number (not ficlFloat or \
1119 ficlComplex), otherwise #f."
1120 FTH obj;
1121
1122 FTH_STACK_CHECK(vm, 1, 1);
1123 obj = fth_pop_ficl_cell(vm);
1124 ficlStackPushBoolean(vm->dataStack, FTH_EXACT_P(obj));
1125 }
1126
1127 static void
ficl_inexact_p(ficlVm * vm)1128 ficl_inexact_p(ficlVm *vm)
1129 {
1130 #define h_inexact_p "( obj -- f ) test if OBJ is an inexact number\n\
1131 1.0 inexact? => #t\n\
1132 1i inexact? => #t\n\
1133 1 inexact? => #f\n\
1134 1/2 inexact? => #f\n\
1135 Return #t if OBJ is an inexact number (ficlFloat, ficlComplex), otherwise #f."
1136 FTH obj;
1137
1138 FTH_STACK_CHECK(vm, 1, 1);
1139 obj = fth_pop_ficl_cell(vm);
1140 ficlStackPushBoolean(vm->dataStack, FTH_INEXACT_P(obj));
1141 }
1142
1143 /*
1144 * Integer types.
1145 *
1146 * Return a FTH fixnum or a FTH llong object depending on N.
1147 */
1148 FTH
fth_make_int(ficlInteger n)1149 fth_make_int(ficlInteger n)
1150 {
1151 if (FIXABLE_P(n))
1152 return (INT_TO_FIX(n));
1153 return (fth_make_llong((ficl2Integer) n));
1154 }
1155
1156 /*
1157 * Return a FTH unsigned fixnum or a FTH ullong object depending on U.
1158 */
1159 FTH
fth_make_unsigned(ficlUnsigned u)1160 fth_make_unsigned(ficlUnsigned u)
1161 {
1162 if (UFIXABLE_P(u))
1163 return (UNSIGNED_TO_FIX(u));
1164 return (fth_make_ullong((ficl2Unsigned) u));
1165 }
1166
1167 /*
1168 * Return a FTH fixnum or a FTH llong object depending on D.
1169 */
1170 FTH
fth_make_long_long(ficl2Integer d)1171 fth_make_long_long(ficl2Integer d)
1172 {
1173 if (FIXABLE_P(d))
1174 return (INT_TO_FIX((ficlInteger) d));
1175 return (fth_make_llong(d));
1176 }
1177
1178 /*
1179 * Return a FTH unsigned fixnum or a FTH ullong object depending on UD.
1180 */
1181 FTH
fth_make_ulong_long(ficl2Unsigned ud)1182 fth_make_ulong_long(ficl2Unsigned ud)
1183 {
1184 if (UFIXABLE_P(ud))
1185 return (UNSIGNED_TO_FIX((ficlUnsigned) ud));
1186 return (fth_make_ullong(ud));
1187 }
1188
1189 /*
1190 * Supposed to be used in FTH_INT_REF() macro.
1191 */
1192 ficlInteger
fth_integer_ref(FTH x)1193 fth_integer_ref(FTH x)
1194 {
1195 if (NUMB_FIXNUM_P(x))
1196 return (FIX_TO_INT(x));
1197
1198 if (FTH_LLONG_P(x))
1199 return (ficlInteger) (FTH_LONG_OBJECT(x));
1200
1201 return ((ficlInteger) x);
1202 }
1203
1204 /*
1205 * Convert any number to type.
1206 *
1207 * Return C ficlInteger from OBJ.
1208 */
1209 ficlInteger
fth_int_ref(FTH obj)1210 fth_int_ref(FTH obj)
1211 {
1212 ficlInteger i;
1213
1214 if (NUMB_FIXNUM_P(obj))
1215 return (FIX_TO_INT(obj));
1216
1217 if (!FTH_NUMBER_T_P(obj))
1218 FTH_WRONG_NUMBER_TYPE(obj, "a ficlInteger");
1219
1220 switch (FTH_INSTANCE_TYPE(obj)) {
1221 case FTH_LLONG_T:
1222 i = (ficlInteger) FTH_LONG_OBJECT(obj);
1223 break;
1224 case FTH_FLOAT_T:
1225 i = (ficlInteger) FTH_FLOAT_REF_INT(obj);
1226 break;
1227 case FTH_RATIO_T:
1228 i = FTH_RATIO_REF_INT(obj);
1229 break;
1230 case FTH_BIGNUM_T:
1231 i = FTH_BIGNUM_REF_INT(obj);
1232 break;
1233 case FTH_COMPLEX_T:
1234 default:
1235 i = (ficlInteger) FTH_ROUND(FTH_COMPLEX_REAL(obj));
1236 break;
1237 }
1238
1239 return (i);
1240 }
1241
1242 /*
1243 * Return C ficlInteger from OBJ. If OBJ doesn't fit in Fixnum, FTH llong,
1244 * FTH float, FTH complex, or any bignum, return fallback.
1245 */
1246 ficlInteger
fth_int_ref_or_else(FTH obj,ficlInteger fallback)1247 fth_int_ref_or_else(FTH obj, ficlInteger fallback)
1248 {
1249 ficlInteger i;
1250
1251 if (NUMB_FIXNUM_P(obj))
1252 return (FIX_TO_INT(obj));
1253
1254 if (!FTH_NUMBER_T_P(obj))
1255 return (fallback);
1256
1257 switch (FTH_INSTANCE_TYPE(obj)) {
1258 case FTH_LLONG_T:
1259 i = (ficlInteger) FTH_LONG_OBJECT(obj);
1260 break;
1261 case FTH_FLOAT_T:
1262 i = (ficlInteger) FTH_FLOAT_REF_INT(obj);
1263 break;
1264 case FTH_RATIO_T:
1265 i = FTH_RATIO_REF_INT(obj);
1266 break;
1267 case FTH_BIGNUM_T:
1268 i = FTH_BIGNUM_REF_INT(obj);
1269 break;
1270 case FTH_COMPLEX_T:
1271 default:
1272 i = (ficlInteger) FTH_ROUND(FTH_COMPLEX_REAL(obj));
1273 break;
1274 }
1275
1276 return (i);
1277 }
1278
1279 /*
1280 * Return C ficl2Integer from OBJ.
1281 */
1282 ficl2Integer
fth_long_long_ref(FTH obj)1283 fth_long_long_ref(FTH obj)
1284 {
1285 ficl2Integer d;
1286
1287 if (FTH_LLONG_P(obj))
1288 return (FTH_LONG_OBJECT(obj));
1289
1290 if (NUMB_FIXNUM_P(obj))
1291 return ((ficl2Integer) FIX_TO_INT(obj));
1292
1293 if (!FTH_NUMBER_T_P(obj))
1294 FTH_WRONG_NUMBER_TYPE(obj, "a ficl2Integer");
1295
1296 switch (FTH_INSTANCE_TYPE(obj)) {
1297 case FTH_FLOAT_T:
1298 d = (ficl2Integer) FTH_FLOAT_REF_INT(obj);
1299 break;
1300 case FTH_RATIO_T:
1301 d = (ficl2Integer) FTH_RATIO_REF_INT(obj);
1302 break;
1303 case FTH_BIGNUM_T:
1304 d = (ficl2Integer) FTH_BIGNUM_REF_INT(obj);
1305 break;
1306 case FTH_COMPLEX_T:
1307 default:
1308 d = (ficl2Integer) FTH_ROUND(FTH_COMPLEX_REAL(obj));
1309 break;
1310 }
1311
1312 return (d);
1313 }
1314
1315 /*
1316 * Return C ficlUnsigned from OBJ.
1317 */
1318 ficlUnsigned
fth_unsigned_ref(FTH obj)1319 fth_unsigned_ref(FTH obj)
1320 {
1321 ficlUnsigned u;
1322
1323 if (NUMB_FIXNUM_P(obj))
1324 return (FIX_TO_UNSIGNED(obj));
1325
1326 if (!FTH_NUMBER_T_P(obj))
1327 FTH_WRONG_NUMBER_TYPE(obj, "a ficlUnsigned");
1328
1329 switch (FTH_INSTANCE_TYPE(obj)) {
1330 case FTH_LLONG_T:
1331 u = (ficlUnsigned) FTH_LONG_OBJECT(obj);
1332 break;
1333 case FTH_FLOAT_T:
1334 u = (ficlUnsigned) FTH_FLOAT_REF_INT(obj);
1335 break;
1336 case FTH_RATIO_T:
1337 u = (ficlUnsigned) FTH_RATIO_REF_INT(obj);
1338 break;
1339 case FTH_BIGNUM_T:
1340 u = (ficlUnsigned) FTH_BIGNUM_REF_UINT(obj);
1341 break;
1342 case FTH_COMPLEX_T:
1343 default:
1344 u = (ficlUnsigned) FTH_ROUND(FTH_COMPLEX_REAL(obj));
1345 break;
1346 }
1347
1348 return (u);
1349 }
1350
1351 /*
1352 * Return C ficl2Unsigned from OBJ.
1353 */
1354 ficl2Unsigned
fth_ulong_long_ref(FTH obj)1355 fth_ulong_long_ref(FTH obj)
1356 {
1357 ficl2Unsigned ud;
1358
1359 if (FTH_ULLONG_P(obj))
1360 return (FTH_ULONG_OBJECT(obj));
1361
1362 if (NUMB_FIXNUM_P(obj))
1363 return ((ficl2Unsigned) FIX_TO_UNSIGNED(obj));
1364
1365 if (!FTH_NUMBER_T_P(obj))
1366 FTH_WRONG_NUMBER_TYPE(obj, "a ficl2Unsigned");
1367
1368 switch (FTH_INSTANCE_TYPE(obj)) {
1369 case FTH_FLOAT_T:
1370 ud = (ficl2Unsigned) FTH_FLOAT_REF_INT(obj);
1371 break;
1372 case FTH_RATIO_T:
1373 ud = (ficl2Unsigned) FTH_RATIO_REF_INT(obj);
1374 break;
1375 case FTH_BIGNUM_T:
1376 ud = (ficl2Unsigned) FTH_BIGNUM_REF_UINT(obj);
1377 break;
1378 case FTH_COMPLEX_T:
1379 default:
1380 ud = (ficl2Unsigned) FTH_ROUND(FTH_COMPLEX_REAL(obj));
1381 break;
1382 }
1383
1384 return (ud);
1385 }
1386
1387 /*
1388 * Return C ficlFloat from OBJ. If OBJ isn't of type Fixnum, FTH llong,
1389 * FTH float, FTH complex, or any bignum, throw an exception.
1390 */
1391 ficlFloat
fth_float_ref(FTH obj)1392 fth_float_ref(FTH obj)
1393 {
1394 ficlFloat f;
1395
1396 if (FTH_FLOAT_T_P(obj))
1397 return (FTH_FLOAT_OBJECT(obj));
1398
1399 if (NUMB_FIXNUM_P(obj))
1400 return ((ficlFloat) FIX_TO_INT(obj));
1401
1402 if (!FTH_NUMBER_T_P(obj))
1403 FTH_WRONG_NUMBER_TYPE(obj, "a ficlFloat");
1404
1405 switch (FTH_INSTANCE_TYPE(obj)) {
1406 case FTH_COMPLEX_T:
1407 f = FTH_COMPLEX_REAL(obj);
1408 break;
1409 case FTH_RATIO_T:
1410 f = FTH_RATIO_REF_FLOAT(obj);
1411 break;
1412 case FTH_BIGNUM_T:
1413 f = FTH_BIGNUM_REF_FLOAT(obj);
1414 break;
1415 case FTH_LLONG_T:
1416 default:
1417 f = (ficlFloat) FTH_LONG_OBJECT(obj);
1418 break;
1419 }
1420
1421 return (f);
1422 }
1423
1424 /*
1425 * Alias for fth_float_ref().
1426 */
1427 ficlFloat
fth_real_ref(FTH x)1428 fth_real_ref(FTH x)
1429 {
1430 return (fth_float_ref(x));
1431 }
1432
1433 ficlFloat
fth_float_ref_or_else(FTH obj,ficlFloat fallback)1434 fth_float_ref_or_else(FTH obj, ficlFloat fallback)
1435 {
1436 ficlFloat f;
1437
1438 if (FTH_FLOAT_T_P(obj))
1439 return (FTH_FLOAT_OBJECT(obj));
1440
1441 if (NUMB_FIXNUM_P(obj))
1442 return ((ficlFloat) FIX_TO_INT(obj));
1443
1444 if (!FTH_NUMBER_T_P(obj))
1445 return (fallback);
1446
1447 switch (FTH_INSTANCE_TYPE(obj)) {
1448 case FTH_COMPLEX_T:
1449 f = FTH_COMPLEX_REAL(obj);
1450 break;
1451 case FTH_RATIO_T:
1452 f = FTH_RATIO_REF_FLOAT(obj);
1453 break;
1454 case FTH_BIGNUM_T:
1455 f = FTH_BIGNUM_REF_FLOAT(obj);
1456 break;
1457 case FTH_LLONG_T:
1458 default:
1459 f = (ficlFloat) FTH_LONG_OBJECT(obj);
1460 break;
1461 }
1462
1463 return (f);
1464 }
1465
1466 #if HAVE_COMPLEX
1467 /*
1468 * Return C ficlComplex from OBJ.
1469 */
1470 ficlComplex
fth_complex_ref(FTH obj)1471 fth_complex_ref(FTH obj)
1472 {
1473 if (FTH_COMPLEX_P(obj))
1474 return (FTH_COMPLEX_OBJECT(obj));
1475 return (fth_float_ref(obj) + 0.0 * _Complex_I);
1476 }
1477 #endif
1478
1479 /*
1480 * Don't forget mpi_free(bn)!
1481 */
1482 ficlBignum
fth_bignum_ref(FTH obj)1483 fth_bignum_ref(FTH obj)
1484 {
1485 ficlBignum bn;
1486
1487 bn = mpi_new();
1488
1489 if (!FTH_NUMBER_T_P(obj)) {
1490 mpi_seti(bn, fth_integer_ref(obj));
1491 return (bn);
1492 }
1493
1494 switch (FTH_INSTANCE_TYPE(obj)) {
1495 case FTH_BIGNUM_T:
1496 mpi_set(bn, FTH_BIGNUM_OBJECT(obj));
1497 break;
1498 case FTH_FLOAT_T:
1499 mpi_setd(bn, FTH_FLOAT_OBJECT(obj));
1500 break;
1501 case FTH_RATIO_T:
1502 mpi_setd(bn, FTH_RATIO_REF_FLOAT(obj));
1503 break;
1504 case FTH_LLONG_T:
1505 mpi_seti(bn, FTH_LONG_OBJECT(obj));
1506 break;
1507 case FTH_COMPLEX_T:
1508 mpi_setd(bn, FTH_COMPLEX_REAL(obj));
1509 break;
1510 default:
1511 mpi_seti(bn, fth_integer_ref(obj));
1512 break;
1513 }
1514
1515 return (bn);
1516 }
1517
1518 /*
1519 * Don't forget mpr_free(rt)!
1520 */
1521 ficlRatio
fth_ratio_ref(FTH obj)1522 fth_ratio_ref(FTH obj)
1523 {
1524 ficlRatio rt;
1525
1526 rt = mpr_new();
1527
1528 if (!FTH_NUMBER_T_P(obj)) {
1529 mpr_seti(rt, fth_integer_ref(obj), 1);
1530 return (rt);
1531 }
1532
1533 switch (FTH_INSTANCE_TYPE(obj)) {
1534 case FTH_RATIO_T:
1535 mpr_set(rt, FTH_RATIO_OBJECT(obj));
1536 break;
1537 case FTH_FLOAT_T:
1538 mpr_setd(rt, FTH_FLOAT_OBJECT(obj));
1539 break;
1540 case FTH_BIGNUM_T:
1541 mpi_set(mpr_num(rt), FTH_BIGNUM_OBJECT(obj));
1542 mpi_seti(mpr_den(rt), 1);
1543 break;
1544 case FTH_LLONG_T:
1545 mpr_seti(rt, (long)FTH_LONG_OBJECT(obj), 1);
1546 break;
1547 case FTH_COMPLEX_T:
1548 mpr_setd(rt, FTH_COMPLEX_REAL(obj));
1549 break;
1550 default:
1551 mpr_seti(rt, fth_integer_ref(obj), 1);
1552 break;
1553 }
1554
1555 return (rt);
1556 }
1557
1558 /* === RANDOM === */
1559
1560 /*
1561 * From clm/cmus.c.
1562 */
1563 static ficlUnsigned fth_rand_rnd;
1564
1565 #define INVERSE_MAX_RAND 0.0000610351563
1566 #define INVERSE_MAX_RAND2 0.000030517579
1567
1568 void
fth_srand(ficlUnsigned val)1569 fth_srand(ficlUnsigned val)
1570 {
1571 fth_rand_rnd = val;
1572 }
1573
1574 static ficlFloat
next_rand(void)1575 next_rand(void)
1576 {
1577 unsigned long val;
1578 fth_rand_rnd = fth_rand_rnd * 1103515245 + 12345;
1579 val = (unsigned long) (fth_rand_rnd >> 16) & 32767;
1580 return ((ficlFloat) val);
1581 }
1582
1583 /* -amp to amp as double */
1584 ficlFloat
fth_frandom(ficlFloat amp)1585 fth_frandom(ficlFloat amp)
1586 {
1587 return (amp * (next_rand() * INVERSE_MAX_RAND - 1.0));
1588 }
1589
1590 /* 0..amp as double */
1591 ficlFloat
fth_random(ficlFloat amp)1592 fth_random(ficlFloat amp)
1593 {
1594 return (amp * (next_rand() * INVERSE_MAX_RAND2));
1595 }
1596
1597 static void
ficl_random(ficlVm * vm)1598 ficl_random(ficlVm *vm)
1599 {
1600 #define h_random "( r -- 0.0..r) return randomized value\n\
1601 1 random => 0.513855\n\
1602 Return pseudo randomized value between 0.0 and R.\n\
1603 See also frandom."
1604 ficlFloat f;
1605
1606 FTH_STACK_CHECK(vm, 1, 1);
1607 f = fth_random(ficlStackPopFloat(vm->dataStack));
1608 ficlStackPushFloat(vm->dataStack, f);
1609 }
1610
1611 static void
ficl_frandom(ficlVm * vm)1612 ficl_frandom(ficlVm *vm)
1613 {
1614 #define h_frandom "( r -- -r...r) return randomized value\n\
1615 1 frandom => -0.64856\n\
1616 Return pseudo randomized value between -R and R.\n\
1617 See also random."
1618 ficlFloat f;
1619
1620 FTH_STACK_CHECK(vm, 1, 1);
1621 f = fth_frandom(ficlStackPopFloat(vm->dataStack));
1622 ficlStackPushFloat(vm->dataStack, f);
1623 }
1624
1625 static void
ficl_rand_seed_ref(ficlVm * vm)1626 ficl_rand_seed_ref(ficlVm *vm)
1627 {
1628 #define h_rand_seed_ref "( -- seed ) return rand seed\n\
1629 rand-seed-ref => 213\n\
1630 Return content of the seed variable fth_rand_rnd.\n\
1631 See also rand-seed-set!."
1632 FTH_STACK_CHECK(vm, 0, 1);
1633 ficlStackPushUnsigned(vm->dataStack, fth_rand_rnd);
1634 }
1635
1636 static void
ficl_rand_seed_set(ficlVm * vm)1637 ficl_rand_seed_set(ficlVm *vm)
1638 {
1639 #define h_rand_seed_set "( seed -- ) set rand seed\n\
1640 213 rand-seed-set!\n\
1641 Set SEED to the seed variable fth_rand_rnd.\n\
1642 See also rand-seed-ref."
1643 FTH_STACK_CHECK(vm, 1, 0);
1644 fth_rand_rnd = ficlStackPopUnsigned(vm->dataStack);
1645 }
1646
1647 /* === FORMATTED NUMBER OUTPUT === */
1648
1649 static void
ficl_dot_r(ficlVm * vm)1650 ficl_dot_r(ficlVm *vm)
1651 {
1652 #define h_dot_r "( n1 n2 -- ) formatted number output\n\
1653 17 3 .r => | 17 |\n\
1654 Print integer N1 in a right-adjusted field of N2 characters.\n\
1655 See also u.r"
1656 ficlInteger n1;
1657 int n2;
1658
1659 FTH_STACK_CHECK(vm, 2, 0);
1660 n2 = (int) ficlStackPopInteger(vm->dataStack);
1661 n1 = ficlStackPopInteger(vm->dataStack);
1662 fth_printf("%*ld ", n2, n1);
1663 }
1664
1665 static void
ficl_u_dot_r(ficlVm * vm)1666 ficl_u_dot_r(ficlVm *vm)
1667 {
1668 #define h_u_dot_r "( u n -- ) formatted number output\n\
1669 17 3 u.r => | 17 |\n\
1670 Print unsigned integer U in a right-adjusted field of N characters.\n\
1671 See also .r"
1672 ficlUnsigned u;
1673 int n;
1674
1675 FTH_STACK_CHECK(vm, 2, 0);
1676 n = (int) ficlStackPopInteger(vm->dataStack);
1677 u = ficlStackPopUnsigned(vm->dataStack);
1678 fth_printf("%*lu ", n, u);
1679 }
1680
1681 static void
ficl_d_dot(ficlVm * vm)1682 ficl_d_dot(ficlVm *vm)
1683 {
1684 #define h_d_dot "( d -- ) number output\n\
1685 17 d. => 17\n\
1686 Print (Forth) double D (ficl2Integer).\n\
1687 See also ud."
1688 FTH_STACK_CHECK(vm, 1, 0);
1689 fth_printf("%lld ", ficlStackPop2Integer(vm->dataStack));
1690 }
1691
1692 static void
ficl_ud_dot(ficlVm * vm)1693 ficl_ud_dot(ficlVm *vm)
1694 {
1695 #define h_ud_dot "( ud -- ) number output\n\
1696 17 ud. => 17\n\
1697 Print (Forth) unsigned double UD (ficl2Unsigned).\n\
1698 See also d."
1699 FTH_STACK_CHECK(vm, 1, 0);
1700 fth_printf("%llu ", ficlStackPop2Unsigned(vm->dataStack));
1701 }
1702
1703 static void
ficl_d_dot_r(ficlVm * vm)1704 ficl_d_dot_r(ficlVm *vm)
1705 {
1706 #define h_d_dot_r "( d n -- ) formatted number output\n\
1707 17 3 d.r => | 17 |\n\
1708 Print (Forth) double D (ficl2Integer) \
1709 in a right-adjusted field of N characters.\n\
1710 See also ud.r"
1711 ficl2Integer d;
1712 int n;
1713
1714 FTH_STACK_CHECK(vm, 2, 0);
1715 n = (int) ficlStackPopInteger(vm->dataStack);
1716 d = ficlStackPop2Integer(vm->dataStack);
1717 fth_printf("%*lld ", n, d);
1718 }
1719
1720 static void
ficl_ud_dot_r(ficlVm * vm)1721 ficl_ud_dot_r(ficlVm *vm)
1722 {
1723 #define h_ud_dot_r "( ud n -- ) formatted number output\n\
1724 17 3 ud.r => | 17 |\n\
1725 Print (Forth) unsigned double UD (ficl2Unsigned) \
1726 in a right-adjusted field of N characters.\n\
1727 See also d.r"
1728 ficl2Unsigned ud;
1729 int n;
1730
1731 FTH_STACK_CHECK(vm, 2, 0);
1732 n = (int) ficlStackPopInteger(vm->dataStack);
1733 ud = ficlStackPop2Unsigned(vm->dataStack);
1734 fth_printf("%*llu ", n, ud);
1735 }
1736
1737 static void
ficl_dnegate(ficlVm * vm)1738 ficl_dnegate(ficlVm *vm)
1739 {
1740 #define h_dnegate "( x -- y ) y = -x"
1741 ficl2Integer x;
1742
1743 FTH_STACK_CHECK(vm, 1, 1);
1744 x = ficlStackPop2Integer(vm->dataStack);
1745 ficlStackPush2Integer(vm->dataStack, -x);
1746 }
1747
1748 static void
ficl_dabs(ficlVm * vm)1749 ficl_dabs(ficlVm *vm)
1750 {
1751 #define h_dabs "( x -- y ) y = abs(x)"
1752 ficl2Integer x;
1753
1754 FTH_STACK_CHECK(vm, 1, 1);
1755 x = ficlStackPop2Integer(vm->dataStack);
1756 ficlStackPush2Integer(vm->dataStack, (x < 0) ? -x : x);
1757 }
1758
1759 static void
ficl_dmin(ficlVm * vm)1760 ficl_dmin(ficlVm *vm)
1761 {
1762 #define h_dmin "( x y -- z ) z = min(x, y)"
1763 ficl2Integer x;
1764 ficl2Integer y;
1765
1766 FTH_STACK_CHECK(vm, 2, 1);
1767 y = ficlStackPop2Integer(vm->dataStack);
1768 x = ficlStackPop2Integer(vm->dataStack);
1769 ficlStackPush2Integer(vm->dataStack, (x < y) ? x : y);
1770 }
1771
1772 static void
ficl_dmax(ficlVm * vm)1773 ficl_dmax(ficlVm *vm)
1774 {
1775 #define h_dmax "( x y -- z ) z = max(x, y)"
1776 ficl2Integer x;
1777 ficl2Integer y;
1778
1779 FTH_STACK_CHECK(vm, 2, 1);
1780 y = ficlStackPop2Integer(vm->dataStack);
1781 x = ficlStackPop2Integer(vm->dataStack);
1782 ficlStackPush2Integer(vm->dataStack, (x > y) ? x : y);
1783 }
1784
1785 static void
ficl_dtwostar(ficlVm * vm)1786 ficl_dtwostar(ficlVm *vm)
1787 {
1788 #define h_dtwostar "( x -- y ) y = x * 2"
1789 ficl2Integer x;
1790
1791 FTH_STACK_CHECK(vm, 1, 1);
1792 x = ficlStackPop2Integer(vm->dataStack);
1793 ficlStackPush2Integer(vm->dataStack, x * 2);
1794 }
1795
1796 static void
ficl_dtwoslash(ficlVm * vm)1797 ficl_dtwoslash(ficlVm *vm)
1798 {
1799 #define h_dtwoslash "( x -- y ) y = x / 2"
1800 ficl2Integer x;
1801
1802 FTH_STACK_CHECK(vm, 1, 1);
1803 x = ficlStackPop2Integer(vm->dataStack);
1804 ficlStackPush2Integer(vm->dataStack, x / 2);
1805 }
1806
1807 N_FUNC_TEST_TWO_OP(ueq, ==, Unsigned);
1808 N_FUNC_TEST_TWO_OP(unoteq, !=, Unsigned);
1809 N_FUNC_TEST_TWO_OP(uless, <, Unsigned);
1810 N_FUNC_TEST_TWO_OP(ulesseq, <=, Unsigned);
1811 N_FUNC_TEST_TWO_OP(ugreater, >, Unsigned);
1812 N_FUNC_TEST_TWO_OP(ugreatereq, >=, Unsigned);
1813
1814 N_FUNC_TEST_ZERO(dzero, ==, 2Integer);
1815 N_FUNC_TEST_ZERO(dnotz, !=, 2Integer);
1816 N_FUNC_TEST_ZERO(dlessz, <, 2Integer);
1817 N_FUNC_TEST_ZERO(dlesseqz, <=, 2Integer);
1818 N_FUNC_TEST_ZERO(dgreaterz, >, 2Integer);
1819 N_FUNC_TEST_ZERO(dgreatereqz, >=, 2Integer);
1820
1821 N_FUNC_TEST_TWO_OP(deq, ==, 2Integer);
1822 N_FUNC_TEST_TWO_OP(dnoteq, !=, 2Integer);
1823 N_FUNC_TEST_TWO_OP(dless, <, 2Integer);
1824 N_FUNC_TEST_TWO_OP(dlesseq, <=, 2Integer);
1825 N_FUNC_TEST_TWO_OP(dgreater, >, 2Integer);
1826 N_FUNC_TEST_TWO_OP(dgreatereq, >=, 2Integer);
1827
1828 N_FUNC_TEST_TWO_OP(dueq, ==, 2Unsigned);
1829 N_FUNC_TEST_TWO_OP(dunoteq, !=, 2Unsigned);
1830 N_FUNC_TEST_TWO_OP(duless, <, 2Unsigned);
1831 N_FUNC_TEST_TWO_OP(dulesseq, <=, 2Unsigned);
1832 N_FUNC_TEST_TWO_OP(dugreater, >, 2Unsigned);
1833 N_FUNC_TEST_TWO_OP(dugreatereq, >=, 2Unsigned);
1834
1835 N_FUNC_TWO_ARGS_OP(dadd, +, 2Integer);
1836 N_FUNC_TWO_ARGS_OP(dsub, -, 2Integer);
1837 N_FUNC_TWO_ARGS_OP(dmul, *, 2Integer);
1838 N_FUNC_TWO_ARGS_OP(ddiv, /, 2Integer);
1839
1840 /* === FLOAT === */
1841
1842 #define h_list_of_float_functions "\
1843 *** FLOAT PRIMITIVES ***\n\
1844 float? inf? nan?\n\
1845 inf nan\n\
1846 f.r uf.r\n\
1847 floats (sfloats and dfloats)\n\
1848 falign f>s s>f\n\
1849 f** (fpow) fabs\n\
1850 fmod floor fceil ftrunc\n\
1851 fround fsqrt fexp fexpm1\n\
1852 flog flogp1 (flog1p) flog2 flog10 falog\n\
1853 fsin fcos ftan fsincos\n\
1854 fasin facos fatan fatan2\n\
1855 fsinh fcosh ftanh\n\
1856 fasinh facosh fatanh\n\
1857 *** FLOAT CONSTANTS ***\n\
1858 euler ln-two ln-ten pi two-pi half-pi sqrt-two"
1859
1860 static char *
format_double(char * buf,size_t size,ficlFloat f)1861 format_double(char *buf, size_t size, ficlFloat f)
1862 {
1863 int i;
1864 int len;
1865 int isize;
1866 int okay;
1867
1868 len = snprintf(buf, size, "%g", f);
1869 okay = 0;
1870
1871 for (i = 0; i < len; i++) {
1872 if (buf[i] == 'e' || buf[i] == '.') {
1873 okay = 1;
1874 break;
1875 }
1876 }
1877
1878 isize = (int) size;
1879
1880 if (!okay && (len + 2) < isize)
1881 buf[len] = '.';
1882
1883 buf[len + 1] = '0';
1884 buf[len + 2] = '\0';
1885 return (buf);
1886 }
1887
1888 static char numbers_scratch[BUFSIZ];
1889
1890 static FTH
fl_inspect(FTH self)1891 fl_inspect(FTH self)
1892 {
1893 ficlFloat f;
1894 FTH fs;
1895 char *s;
1896
1897 f = FTH_FLOAT_OBJECT(self);
1898 fs = fth_make_string_format("%s: ", FTH_INSTANCE_NAME(self));
1899
1900 if (fth_isnan(f))
1901 return (fth_string_sformat(fs, "NaN"));
1902
1903 if (fth_isinf(f))
1904 fth_string_sformat(fs, "%sInfinite", f < 0 ? "-" : "");
1905
1906 s = format_double(numbers_scratch, sizeof(numbers_scratch), f);
1907 return (fth_string_sformat(fs, "%s", s));
1908 }
1909
1910 static FTH
fl_to_string(FTH self)1911 fl_to_string(FTH self)
1912 {
1913 ficlFloat f;
1914 char *s;
1915
1916 f = FTH_FLOAT_OBJECT(self);
1917
1918 if (fth_isnan(f))
1919 return (fth_make_string("#<nan>"));
1920
1921 if (fth_isinf(f))
1922 return (fth_make_string("#<inf>"));
1923
1924 s = format_double(numbers_scratch, sizeof(numbers_scratch), f);
1925 return (fth_make_string(s));
1926 }
1927
1928 static FTH
fl_copy(FTH self)1929 fl_copy(FTH self)
1930 {
1931 return (fth_make_float(FTH_FLOAT_OBJECT(self)));
1932 }
1933
1934 static FTH
fl_equal_p(FTH self,FTH obj)1935 fl_equal_p(FTH self, FTH obj)
1936 {
1937 return (BOOL_TO_FTH(FTH_FLOAT_OBJECT(self) == FTH_FLOAT_OBJECT(obj)));
1938 }
1939
1940 /*
1941 * Return a FTH float object from F.
1942 */
1943 FTH
fth_make_float(ficlFloat f)1944 fth_make_float(ficlFloat f)
1945 {
1946 FTH self;
1947
1948 self = fth_make_instance(float_tag, NULL);
1949 FTH_FLOAT_OBJECT_SET(self, f);
1950 return (self);
1951 }
1952
1953 FTH
fth_float_copy(FTH obj)1954 fth_float_copy(FTH obj)
1955 {
1956 if (FTH_FLOAT_T_P(obj))
1957 return (fl_copy(obj));
1958 return (obj);
1959 }
1960
1961 static void
ficl_float_p(ficlVm * vm)1962 ficl_float_p(ficlVm *vm)
1963 {
1964 #define h_float_p "( obj -- f ) test if OBJ is a float number\n\
1965 nil float? => #f\n\
1966 1 float? => #f\n\
1967 1.0 float? => #t\n\
1968 Return #t if OBJ is a float object, otherwise #f."
1969 FTH obj;
1970
1971 FTH_STACK_CHECK(vm, 1, 1);
1972 obj = fth_pop_ficl_cell(vm);
1973 ficlStackPushBoolean(vm->dataStack, FTH_FLOAT_T_P(obj));
1974 }
1975
1976 static void
ficl_inf_p(ficlVm * vm)1977 ficl_inf_p(ficlVm *vm)
1978 {
1979 #define h_inf_p "( obj -- f ) test if OBJ is Infinite\n\
1980 nil inf? => #f\n\
1981 0 inf? => #f\n\
1982 inf inf? => #t\n\
1983 Return #t if OBJ is Infinite, otherwise #f.\n\
1984 See also nan?, inf, nan."
1985 FTH obj;
1986 int flag;
1987
1988 flag = 0;
1989 FTH_STACK_CHECK(vm, 1, 1);
1990 obj = fth_pop_ficl_cell(vm);
1991
1992 if (FTH_NUMBER_P(obj))
1993 flag = fth_isinf(fth_float_ref(obj));
1994
1995 ficlStackPushBoolean(vm->dataStack, flag);
1996 }
1997
1998 static void
ficl_nan_p(ficlVm * vm)1999 ficl_nan_p(ficlVm *vm)
2000 {
2001 #define h_nan_p "( obj -- f ) test if OBJ is Not a Number\n\
2002 nil nan? => #f\n\
2003 0 nan? => #f\n\
2004 nan nan? => #t\n\
2005 Return #t if OBJ is Not a Number, otherwise #f.\n\
2006 See also inf?, inf, nan."
2007 FTH obj;
2008 int flag;
2009
2010 flag = 0;
2011 FTH_STACK_CHECK(vm, 1, 1);
2012 obj = fth_pop_ficl_cell(vm);
2013
2014 if (FTH_NUMBER_P(obj))
2015 flag = fth_isnan(fth_float_ref(obj));
2016
2017 ficlStackPushBoolean(vm->dataStack, flag);
2018 }
2019
2020 static void
ficl_inf(ficlVm * vm)2021 ficl_inf(ficlVm *vm)
2022 {
2023 #define h_inf "( -- Inf ) Return Infinity."
2024 ficlStackPushFloat(vm->dataStack, FTH_INF);
2025 }
2026
2027 static void
ficl_nan(ficlVm * vm)2028 ficl_nan(ficlVm *vm)
2029 {
2030 #define h_nan "( -- NaN ) Return Not-A-Number."
2031 ficlStackPushFloat(vm->dataStack, FTH_NAN);
2032 }
2033
2034 static void
ficl_f_dot_r(ficlVm * vm)2035 ficl_f_dot_r(ficlVm *vm)
2036 {
2037 #define h_f_dot_r "( r n -- ) formatted number output\n\
2038 17.0 3 f.r => |17.000 |\n\
2039 17.0 6 f.r => |17.000000 |\n\
2040 Print float R with N digits after decimal point."
2041 ficlFloat f;
2042 int n;
2043
2044 FTH_STACK_CHECK(vm, 2, 0);
2045 n = (int) ficlStackPopInteger(vm->dataStack);
2046 f = ficlStackPopFloat(vm->dataStack);
2047 fth_printf("%.*f ", n, f);
2048 }
2049
2050 static void
ficl_uf_dot_r(ficlVm * vm)2051 ficl_uf_dot_r(ficlVm *vm)
2052 {
2053 #define h_uf_dot_r "( r len-all len-after-comma -- ) formatted number\n\
2054 17.0 8 3 uf.r => | 17.000 |\n\
2055 17.0 8 2 uf.r => | 17.00 |\n\
2056 Print float R in a right-adjusted field of LEN-ALL characters \
2057 with LEN-AFTER-COMMA digits."
2058 ficlFloat f;
2059 int n, all;
2060
2061 FTH_STACK_CHECK(vm, 2, 1);
2062 n = (int) ficlStackPopInteger(vm->dataStack);
2063 all = (int) ficlStackPopInteger(vm->dataStack);
2064 f = ficlStackPopFloat(vm->dataStack);
2065 fth_printf("%*.*f ", all, n, f);
2066 }
2067
2068 static void
ficl_dfloats(ficlVm * vm)2069 ficl_dfloats(ficlVm *vm)
2070 {
2071 #define h_dfloats "( n1 -- n2 ) return address units\n\
2072 1 dfloats => 8\n\
2073 4 dfloats => 32\n\
2074 N2 is the number of address units of N1 dfloats (double)."
2075 ficlInteger n, s;
2076
2077 FTH_STACK_CHECK(vm, 1, 1);
2078 n = ficlStackPopInteger(vm->dataStack);
2079 s = (ficlInteger) sizeof(ficlFloat);
2080 ficlStackPushInteger(vm->dataStack, n * s);
2081 }
2082
2083 static void
ficl_falign(ficlVm * vm)2084 ficl_falign(ficlVm *vm)
2085 {
2086 #define h_falign "( -- ) align dictionary"
2087 ficlDictionaryAlign(ficlVmGetDictionary(vm));
2088 }
2089
2090 /*
2091 * Thanks to Sanjay Jain, we use expm1() and log1p()!
2092 */
2093 static void
ficl_fexpm1(ficlVm * vm)2094 ficl_fexpm1(ficlVm *vm)
2095 {
2096 ficlFloat f;
2097
2098 FTH_STACK_CHECK(vm, 1, 1);
2099 f = ficlStackPopFloat(vm->dataStack);
2100 #if defined(HAVE_EXPM1)
2101 #define h_fexpm1 "( x -- y ) y = expm1(x)"
2102 ficlStackPushFloat(vm->dataStack, expm1(f));
2103 #else
2104 #define h_fexpm1 "( x -- y ) y = exp(x) - 1.0"
2105 ficlStackPushFloat(vm->dataStack, exp(f) - 1.0);
2106 #endif
2107 }
2108
2109 static void
ficl_flogp1(ficlVm * vm)2110 ficl_flogp1(ficlVm *vm)
2111 {
2112 ficlFloat f;
2113
2114 FTH_STACK_CHECK(vm, 1, 1);
2115 f = ficlStackPopFloat(vm->dataStack);
2116
2117 if (f >= 0.0) {
2118 #if defined(HAVE_LOG1P)
2119 #define h_flogp1 "( x -- y ) y = log1p(x)"
2120 ficlStackPushFloat(vm->dataStack, log1p(f));
2121 #else
2122 #define h_flogp1 "( x -- y ) y = log(x + 1.0)"
2123 ficlStackPushFloat(vm->dataStack, log(f + 1.0));
2124 #endif
2125 return;
2126 }
2127 FTH_MATH_ERROR_THROW("log1p, x < 0");
2128 /* NOTREACHED */
2129 }
2130
2131 static void
ficl_falog(ficlVm * vm)2132 ficl_falog(ficlVm *vm)
2133 {
2134 #define h_falog "( x -- y ) y = pow(10.0, x)"
2135 ficlFloat f;
2136
2137 FTH_STACK_CHECK(vm, 1, 1);
2138 f = ficlStackPopFloat(vm->dataStack);
2139 ficlStackPushFloat(vm->dataStack, FTH_POW(10.0, f));
2140 }
2141
2142 static void
ficl_fsincos(ficlVm * vm)2143 ficl_fsincos(ficlVm *vm)
2144 {
2145 #define h_fsincos "( x -- y z ) y = sin(x), z = cos(x)"
2146 ficlFloat f;
2147
2148 FTH_STACK_CHECK(vm, 1, 2);
2149 f = ficlStackPopFloat(vm->dataStack);
2150 ficlStackPushFloat(vm->dataStack, sin(f));
2151 ficlStackPushFloat(vm->dataStack, cos(f));
2152 }
2153
2154 N_FUNC_ONE_ARG(fabs, fabs, Float);
2155 N_FUNC_ONE_ARG(floor, fth_floor, Float);
2156 N_FUNC_ONE_ARG(fceil, fth_ceil, Float);
2157 N_FUNC_ONE_ARG(ftrunc, fth_trunc, Float);
2158 N_FUNC_ONE_ARG(fround, fth_rint, Float);
2159 N_FUNC_ONE_ARG(fsqrt, sqrt, Float);
2160 N_FUNC_ONE_ARG(fexp, exp, Float);
2161 N_FUNC_ONE_ARG(flog, fth_log, Float);
2162 N_FUNC_ONE_ARG(flog2, fth_log2, Float);
2163 N_FUNC_ONE_ARG(flog10, fth_log10, Float);
2164 N_FUNC_ONE_ARG(fsin, sin, Float);
2165 N_FUNC_ONE_ARG(fcos, cos, Float);
2166 N_FUNC_ONE_ARG(ftan, tan, Float);
2167 N_FUNC_ONE_ARG(fasin, asin, Float);
2168 N_FUNC_ONE_ARG(facos, acos, Float);
2169 N_FUNC_ONE_ARG(fatan, atan, Float);
2170 N_FUNC_ONE_ARG(fsinh, sinh, Float);
2171 N_FUNC_ONE_ARG(fcosh, cosh, Float);
2172 N_FUNC_ONE_ARG(ftanh, tanh, Float);
2173 N_FUNC_ONE_ARG(fasinh, asinh, Float);
2174 N_FUNC_ONE_ARG(facosh, acosh, Float);
2175 N_FUNC_ONE_ARG(fatanh, atanh, Float);
2176 N_FUNC_TWO_ARGS(fmod, fmod, Float);
2177 N_FUNC_TWO_ARGS(fpow, fth_pow, Float);
2178 N_FUNC_TWO_ARGS(fatan2, atan2, Float);
2179
2180 /*
2181 * Parse ficlInteger, ficl2Integer, ficlUnsigned, ficl2Unsigned, and
2182 * ficlFloat (1, 1., 1.0, 1e, etc).
2183 */
2184 int
ficl_parse_number(ficlVm * vm,ficlString s)2185 ficl_parse_number(ficlVm *vm, ficlString s)
2186 {
2187 int base;
2188 char *test;
2189 char *str;
2190 ficlInteger i;
2191 ficlUnsigned u;
2192 ficl2Integer di;
2193 ficl2Unsigned ud;
2194 ficlFloat f;
2195
2196 if (s.length < 1 || s.length >= FICL_PAD_SIZE)
2197 return (FICL_FALSE);
2198
2199 base = (int) vm->base;
2200 str = vm->pad;
2201 strncpy(str, s.text, s.length);
2202 str[s.length] = '\0';
2203
2204 /* ficlInteger */
2205 i = strtol(str, &test, base);
2206
2207 if (*test == '\0' && errno != ERANGE) {
2208 ficlStackPushInteger(vm->dataStack, i);
2209 goto okay;
2210 }
2211 /* 3e => 3. */
2212 if (str[s.length - 1] == 'e')
2213 str[s.length - 1] = '.';
2214
2215 /* ficlFloat */
2216 f = strtod(str, &test);
2217
2218 if (*test == '\0' && errno != ERANGE) {
2219 ficlStackPushFloat(vm->dataStack, f);
2220 goto okay;
2221 }
2222 /* ficl2Integer */
2223 di = strtoll(str, &test, base);
2224
2225 if (*test == '\0' && errno != ERANGE) {
2226 ficlStackPush2Integer(vm->dataStack, di);
2227 goto okay;
2228 }
2229 /* ficlUnsigned */
2230 u = strtoul(str, &test, base);
2231
2232 if (*test == '\0' && errno != ERANGE) {
2233 ficlStackPushUnsigned(vm->dataStack, u);
2234 goto okay;
2235 }
2236 /* ficl2Unsigned */
2237 ud = strtoull(str, &test, base);
2238
2239 if (*test == '\0' && errno != ERANGE) {
2240 ficlStackPush2Unsigned(vm->dataStack, ud);
2241 goto okay;
2242 }
2243 errno = 0;
2244 return (FICL_FALSE);
2245
2246 okay:
2247 errno = 0;
2248
2249 if (vm->state == FICL_VM_STATE_COMPILE)
2250 ficlPrimitiveLiteralIm(vm);
2251
2252 return (FICL_TRUE);
2253 }
2254
2255 /* === COMPLEX === */
2256
2257 #if HAVE_COMPLEX
2258
2259 #define h_list_of_complex_functions "\
2260 *** COMPLEX PRIMITIVES ***\n\
2261 complex? real-ref imag-ref (image-ref)\n\
2262 make-rectangular (>complex)\n\
2263 make-polar\n\
2264 c. s>c c>s f>c c>f q>c (r>c) >c\n\
2265 c0= c0<> c= c<>\n\
2266 c+ c- c* c/ 1/c\n\
2267 carg cabs (magnitude) cabs2\n\
2268 c** (cpow) conj (conjugate)\n\
2269 csqrt cexp clog clog10\n\
2270 csin ccos ctan\n\
2271 casin cacos catan catan2\n\
2272 csinh ccosh ctanh\n\
2273 casinh cacosh catanh\n\
2274 See also long-long and float."
2275
2276 static char numbers_scratch_02[BUFSIZ];
2277
2278 static FTH
cp_inspect(FTH self)2279 cp_inspect(FTH self)
2280 {
2281 char *re;
2282 char *im;
2283 size_t size;
2284 FTH fs;
2285
2286 re = numbers_scratch;
2287 im = numbers_scratch_02;
2288 size = sizeof(numbers_scratch);
2289 fs = fth_make_string_format("%s: ", FTH_INSTANCE_NAME(self));
2290 fth_string_scat(fs, "real ");
2291 fth_string_scat(fs, format_double(re, size, FTH_COMPLEX_REAL(self)));
2292 fth_string_scat(fs, ", image ");
2293 fth_string_scat(fs, format_double(im, size, FTH_COMPLEX_IMAG(self)));
2294 return (fs);
2295 }
2296
2297 static FTH
cp_to_string(FTH self)2298 cp_to_string(FTH self)
2299 {
2300 char *re;
2301 char *im;
2302 size_t size;
2303 FTH fs;
2304
2305 re = numbers_scratch;
2306 im = numbers_scratch_02;
2307 size = sizeof(numbers_scratch);
2308 fs = fth_make_string(format_double(re, size, FTH_COMPLEX_REAL(self)));
2309 fth_string_scat(fs, FTH_COMPLEX_IMAG(self) >= 0.0 ? "+" : "");
2310 fth_string_scat(fs, format_double(im, size, FTH_COMPLEX_IMAG(self)));
2311 fth_string_scat(fs, "i");
2312 return (fs);
2313 }
2314
2315 static FTH
cp_copy(FTH self)2316 cp_copy(FTH self)
2317 {
2318 return (fth_make_complex(FTH_COMPLEX_OBJECT(self)));
2319 }
2320
2321 static FTH
cp_equal_p(FTH self,FTH obj)2322 cp_equal_p(FTH self, FTH obj)
2323 {
2324 return (BOOL_TO_FTH(FTH_COMPLEX_REAL(self) == FTH_COMPLEX_REAL(obj) &&
2325 FTH_COMPLEX_IMAG(self) == FTH_COMPLEX_IMAG(obj)));
2326 }
2327
2328 #endif /* HAVE_COMPLEX */
2329
2330 static void
ficl_complex_p(ficlVm * vm)2331 ficl_complex_p(ficlVm *vm)
2332 {
2333 #define h_complex_p "( obj -- f ) test if OBJ is a complex number\n\
2334 nil complex? => #f\n\
2335 1 complex? => #f\n\
2336 1+i complex? => #t\n\
2337 Return #t if OBJ is a complex object, otherwise #f."
2338 FTH obj;
2339
2340 FTH_STACK_CHECK(vm, 1, 1);
2341 obj = fth_pop_ficl_cell(vm);
2342 ficlStackPushBoolean(vm->dataStack, FTH_COMPLEX_P(obj));
2343 }
2344
2345 static void
ficl_creal(ficlVm * vm)2346 ficl_creal(ficlVm *vm)
2347 {
2348 #define h_creal "( numb -- re ) return number's real part\n\
2349 1 real-ref => 1.0\n\
2350 1.0 real-ref => 1.0\n\
2351 1+i real-ref => 1.0\n\
2352 Return the real part of NUMB.\n\
2353 See also imag-ref."
2354 ficlFloat f;
2355 FTH obj;
2356
2357 FTH_STACK_CHECK(vm, 1, 1);
2358 obj = fth_pop_ficl_cell(vm);
2359 #if HAVE_COMPLEX
2360 if (FTH_COMPLEX_P(obj))
2361 f = FTH_COMPLEX_REAL(obj);
2362 else
2363 f = fth_float_ref(obj);
2364 #else
2365 f = fth_float_ref(obj);
2366 #endif
2367 ficlStackPushFloat(vm->dataStack, f);
2368 }
2369
2370 static void
ficl_cimage(ficlVm * vm)2371 ficl_cimage(ficlVm *vm)
2372 {
2373 #define h_cimage "( numb -- im ) return number's image part\n\
2374 1 imag-ref => 0.0\n\
2375 1.0 imag-ref => 0.0\n\
2376 1+i imag-ref => 1.0\n\
2377 Return the image part of NUMB.\n\
2378 See also real-ref."
2379 FTH obj;
2380 ficlFloat f;
2381
2382 FTH_STACK_CHECK(vm, 1, 1);
2383 obj = fth_pop_ficl_cell(vm);
2384 f = 0.0;
2385 #if HAVE_COMPLEX
2386 if (FTH_COMPLEX_P(obj))
2387 f = FTH_COMPLEX_IMAG(obj);
2388 #endif
2389 ficlStackPushFloat(vm->dataStack, f);
2390 }
2391
2392 #if HAVE_COMPLEX
2393
2394 /*
2395 * Return a FTH complex object from Z.
2396 */
2397 FTH
fth_make_complex(ficlComplex z)2398 fth_make_complex(ficlComplex z)
2399 {
2400 FTH self;
2401
2402 self = fth_make_instance(complex_tag, NULL);
2403 FTH_COMPLEX_OBJECT_SET(self, z);
2404 return (self);
2405 }
2406
2407 FTH
fth_make_rectangular(ficlFloat real,ficlFloat image)2408 fth_make_rectangular(ficlFloat real, ficlFloat image)
2409 {
2410 return (fth_make_complex(real + image * _Complex_I));
2411 }
2412
2413 static void
ficl_make_complex_rectangular(ficlVm * vm)2414 ficl_make_complex_rectangular(ficlVm *vm)
2415 {
2416 #define h_make_complex_rectangular "( real image -- complex ) complex numb\n\
2417 1 1 make-rectangular => 1.0+1.0i\n\
2418 Return complex object with REAL and IMAGE part.\n\
2419 See also make-polar."
2420 ficlFloat real, image;
2421
2422 FTH_STACK_CHECK(vm, 2, 1);
2423 image = fth_float_ref(fth_pop_ficl_cell(vm));
2424 real = fth_float_ref(fth_pop_ficl_cell(vm));
2425 ficlStackPushFTH(vm->dataStack, fth_make_rectangular(real, image));
2426 }
2427
2428 static ficlComplex
make_polar(ficlFloat real,ficlFloat theta)2429 make_polar(ficlFloat real, ficlFloat theta)
2430 {
2431 return (real * cos(theta) + real * sin(theta) * _Complex_I);
2432 }
2433
2434 FTH
fth_make_polar(ficlFloat real,ficlFloat theta)2435 fth_make_polar(ficlFloat real, ficlFloat theta)
2436 {
2437 return (fth_make_complex(make_polar(real, theta)));
2438 }
2439
2440 static void
ficl_make_complex_polar(ficlVm * vm)2441 ficl_make_complex_polar(ficlVm *vm)
2442 {
2443 #define h_make_complex_polar "( real theta -- complex ) polar complex numb\n\
2444 1 1 make-polar => 0.540302+0.841471i\n\
2445 Return polar complex object from REAL and THETA.\n\
2446 See also make-rectangular."
2447 ficlFloat real, theta;
2448
2449 FTH_STACK_CHECK(vm, 2, 1);
2450 theta = fth_float_ref(fth_pop_ficl_cell(vm));
2451 real = fth_float_ref(fth_pop_ficl_cell(vm));
2452 ficlStackPushFTH(vm->dataStack, fth_make_polar(real, theta));
2453 }
2454
2455 static void
ficl_c_dot(ficlVm * vm)2456 ficl_c_dot(ficlVm *vm)
2457 {
2458 #define h_c_dot "( c -- ) print number\n\
2459 1+i c. => |1.0+1.0i |\n\
2460 Print complex number C."
2461 ficlComplex cp;
2462
2463 FTH_STACK_CHECK(vm, 1, 0);
2464 cp = ficlStackPopComplex(vm->dataStack);
2465 fth_printf("%f%s%fi ",
2466 creal(cp),
2467 cimag(cp) >= 0.0 ? "+" : "",
2468 cimag(cp));
2469 }
2470
2471 static void
ficl_creciprocal(ficlVm * vm)2472 ficl_creciprocal(ficlVm *vm)
2473 {
2474 #define h_creciprocal "( x -- y ) y = 1 / x"
2475 ficlComplex cp;
2476
2477 FTH_STACK_CHECK(vm, 1, 1);
2478 cp = ficlStackPopComplex(vm->dataStack);
2479 ficlStackPushComplex(vm->dataStack, 1.0 / cp);
2480 }
2481
2482 static void
ficl_ceqz(ficlVm * vm)2483 ficl_ceqz(ficlVm *vm)
2484 {
2485 #define h_ceqz "( x -- f ) x == 0 => flag"
2486 ficlComplex cp;
2487 int flag;
2488
2489 FTH_STACK_CHECK(vm, 1, 1);
2490 cp = ficlStackPopComplex(vm->dataStack);
2491 flag = (creal(cp) == 0.0);
2492
2493 if (flag)
2494 flag = (cimag(cp) == 0.0);
2495
2496 ficlStackPushBoolean(vm->dataStack, flag);
2497 }
2498
2499 static void
ficl_cnoteqz(ficlVm * vm)2500 ficl_cnoteqz(ficlVm *vm)
2501 {
2502 #define h_cnoteqz "( x -- f ) x != 0 => flag"
2503 ficlComplex cp;
2504 int flag;
2505
2506 FTH_STACK_CHECK(vm, 1, 1);
2507 cp = ficlStackPopComplex(vm->dataStack);
2508 flag = (creal(cp) != 0.0);
2509
2510 if (flag)
2511 flag = (cimag(cp) != 0.0);
2512
2513 ficlStackPushBoolean(vm->dataStack, flag);
2514 }
2515
2516 static void
ficl_ceq(ficlVm * vm)2517 ficl_ceq(ficlVm *vm)
2518 {
2519 #define h_ceq "( x y -- f ) x == y => flag"
2520 ficlComplex x, y;
2521 int flag;
2522
2523 FTH_STACK_CHECK(vm, 2, 1);
2524 y = ficlStackPopComplex(vm->dataStack);
2525 x = ficlStackPopComplex(vm->dataStack);
2526 flag = (creal(x) == creal(y));
2527
2528 if (flag)
2529 flag = (cimag(x) == cimag(y));
2530
2531 ficlStackPushBoolean(vm->dataStack, flag);
2532 }
2533
2534 static void
ficl_cnoteq(ficlVm * vm)2535 ficl_cnoteq(ficlVm *vm)
2536 {
2537 #define h_cnoteq "( x y -- f ) x != y => flag"
2538 ficlComplex x, y;
2539 int flag;
2540
2541 FTH_STACK_CHECK(vm, 2, 1);
2542 y = ficlStackPopComplex(vm->dataStack);
2543 x = ficlStackPopComplex(vm->dataStack);
2544 flag = (creal(x) != creal(y));
2545
2546 if (flag)
2547 flag = (cimag(x) != cimag(y));
2548
2549 ficlStackPushBoolean(vm->dataStack, flag);
2550 }
2551
2552 N_FUNC_TWO_ARGS_OP(cadd, +, Complex);
2553 N_FUNC_TWO_ARGS_OP(csub, -, Complex);
2554 N_FUNC_TWO_ARGS_OP(cmul, *, Complex);
2555 N_FUNC_TWO_ARGS_OP(cdiv, /, Complex);
2556
2557 N_FUNC_ONE_ARG(carg, carg, Complex);
2558 N_FUNC_ONE_ARG(cabs, cabs, Complex);
2559 N_FUNC_ONE_ARG(cabs2, cabs2, Complex);
2560 N_FUNC_TWO_ARGS(cpow, cpow, Complex);
2561 N_FUNC_ONE_ARG(cconj, conj, Complex);
2562 N_FUNC_ONE_ARG(csqrt, csqrt, Complex);
2563 N_FUNC_ONE_ARG(cexp, cexp, Complex);
2564 N_FUNC_ONE_ARG(clog, clog, Complex);
2565 N_FUNC_ONE_ARG(clog10, clog10, Complex);
2566 N_FUNC_ONE_ARG(csin, csin, Complex);
2567 N_FUNC_ONE_ARG(ccos, ccos, Complex);
2568 N_FUNC_ONE_ARG(ctan, ctan, Complex);
2569 N_FUNC_ONE_ARG(casin, casin, Complex);
2570 N_FUNC_ONE_ARG(cacos, cacos, Complex);
2571 N_FUNC_ONE_ARG(catan, catan, Complex);
2572 N_FUNC_TWO_ARGS(catan2, catan2, Complex);
2573 N_FUNC_ONE_ARG(csinh, csinh, Complex);
2574 N_FUNC_ONE_ARG(ccosh, ccosh, Complex);
2575 N_FUNC_ONE_ARG(ctanh, ctanh, Complex);
2576 N_FUNC_ONE_ARG(casinh, casinh, Complex);
2577 N_FUNC_ONE_ARG(cacosh, cacosh, Complex);
2578 N_FUNC_ONE_ARG(catanh, catanh, Complex);
2579
2580 /*
2581 * Parse ficlComplex (1i, 1-i, -1+1i, 1.0+1.0i, etc).
2582 */
2583 int
ficl_parse_complex(ficlVm * vm,ficlString s)2584 ficl_parse_complex(ficlVm *vm, ficlString s)
2585 {
2586 ficlFloat re;
2587 ficlFloat im;
2588 size_t loc_len;
2589 char *locp;
2590 char *locn;
2591 char *test;
2592 char *loc;
2593 char *sreal;
2594 char *simag;
2595 char re_buf[FICL_PAD_SIZE];
2596
2597 if (s.length < 2 || tolower((int) s.text[s.length - 1]) != 'i')
2598 return (FICL_FALSE);
2599
2600 if (s.length >= FICL_PAD_SIZE)
2601 return (FICL_FALSE);
2602
2603 sreal = re_buf;
2604 simag = vm->pad;
2605 strncpy(simag, s.text, s.length);
2606 simag[s.length] = '\0';
2607 locp = strrchr(simag, '+');
2608 locn = strrchr(simag, '-');
2609 loc = FICL_MAX(locp, locn);
2610
2611 if (loc == NULL) {
2612 loc = strrchr(simag, 'i');
2613
2614 if (loc == NULL)
2615 loc = strrchr(simag, 'I');
2616 }
2617
2618 if (loc == NULL)
2619 return (FICL_FALSE);
2620
2621 strncpy(sreal, simag, (size_t) (loc - simag));
2622 sreal[loc - simag] = '\0';
2623 re = strtod(sreal, &test);
2624
2625 if (*test != '\0' || errno == ERANGE) {
2626 errno = 0;
2627 return (FICL_FALSE);
2628 }
2629
2630 loc_len = fth_strlen(loc); /* skip \0 above */
2631
2632 if (loc_len > 2) {
2633 loc[loc_len - 1] = '\0'; /* discard trailing i */
2634 im = strtod(loc, &test);
2635 if (*test != '\0' || errno == ERANGE)
2636 return (FICL_FALSE);
2637 } else {
2638 if (loc[0] == '+' || tolower((int) loc[0]) == 'i')
2639 im = 1.0;
2640 else
2641 im = -1.0;
2642 }
2643 ficlStackPushFTH(vm->dataStack, fth_make_rectangular(re, im));
2644
2645 if (vm->state == FICL_VM_STATE_COMPILE)
2646 ficlPrimitiveLiteralIm(vm);
2647
2648 return (FICL_TRUE);
2649 }
2650
2651 #endif /* HAVE_COMPLEX */
2652
2653 /* === BIGNUM via xedit/lisp/mp === */
2654
2655 #define h_list_of_bignum_functions "\
2656 *** BIGNUMB PRIMITIVES ***\n\
2657 bignum? >bignum bn.\n\
2658 s>b b>s f>b b>f\n\
2659 b0= b0<> b0< b0> b0<= b0>=\n\
2660 b= b<> b< b> b<= b>=\n\
2661 b+ b- b* b/\n\
2662 bgcd blcm b** (bpow)\n\
2663 broot bsqrt\n\
2664 bnegate babs bmin bmax\n\
2665 b2* b2/ bmod b/mod blshift brshift"
2666
2667 static void
ficl_bignum_p(ficlVm * vm)2668 ficl_bignum_p(ficlVm *vm)
2669 {
2670 #define h_bignum_p "( obj -- f ) test if OBJ is a bignum\n\
2671 nil bignum? => #f\n\
2672 1e100 bignum? => #f\n\
2673 12345678901234567890 bignum? => #t\n\
2674 Return #t if OBJ is a bignum object, otherwise #f."
2675 FTH obj;
2676
2677 FTH_STACK_CHECK(vm, 1, 1);
2678 obj = fth_pop_ficl_cell(vm);
2679 ficlStackPushBoolean(vm->dataStack, FTH_BIGNUM_P(obj));
2680 }
2681
2682 static FTH
bn_inspect(FTH self)2683 bn_inspect(FTH self)
2684 {
2685 return (fth_make_string_format("%s: %S",
2686 FTH_INSTANCE_NAME(self), bn_to_string(self)));
2687 }
2688
2689 static FTH
bn_to_string(FTH self)2690 bn_to_string(FTH self)
2691 {
2692 FTH fs;
2693 char *buf;
2694
2695 buf = mpi_getstr(NULL, FTH_BIGNUM_OBJECT(self), 10);
2696 fs = fth_make_string(buf);
2697 mp_free(buf);
2698 return (fs);
2699 }
2700
2701 static FTH
bn_copy(FTH self)2702 bn_copy(FTH self)
2703 {
2704 ficlBignum res;
2705
2706 res = mpi_new();
2707 mpi_set(res, FTH_BIGNUM_OBJECT(self));
2708 return (fth_make_bignum(res));
2709 }
2710
2711 static FTH
bn_equal_p(FTH self,FTH obj)2712 bn_equal_p(FTH self, FTH obj)
2713 {
2714 int flag;
2715
2716 flag = mpi_cmp(FTH_BIGNUM_OBJECT(self), FTH_BIGNUM_OBJECT(obj));
2717 return (BOOL_TO_FTH(flag == 0));
2718 }
2719
2720 static void
bn_free(FTH self)2721 bn_free(FTH self)
2722 {
2723 mpi_free(FTH_BIGNUM_OBJECT(self));
2724 }
2725
2726 enum {
2727 BN_ADD,
2728 BN_SUB,
2729 BN_MUL,
2730 BN_DIV
2731 };
2732
2733 static ficlBignum
bn_math(FTH m,FTH n,int type)2734 bn_math(FTH m, FTH n, int type)
2735 {
2736 ficlBignum x;
2737 ficlBignum y;
2738 ficlBignum z;
2739
2740 x = fth_bignum_ref(m);
2741 y = fth_bignum_ref(n);
2742 z = mpi_new();
2743
2744 switch (type) {
2745 case BN_ADD:
2746 mpi_add(z, x, y);
2747 break;
2748 case BN_SUB:
2749 mpi_sub(z, x, y);
2750 break;
2751 case BN_MUL:
2752 mpi_mul(z, x, y);
2753 break;
2754 case BN_DIV:
2755 default:
2756 mpi_div(z, x, y);
2757 break;
2758 }
2759
2760 mpi_free(x);
2761 mpi_free(y);
2762 return (z);
2763 }
2764
2765 static FTH
bn_add(FTH m,FTH n)2766 bn_add(FTH m, FTH n)
2767 {
2768 return (fth_make_bignum(bn_math(m, n, BN_ADD)));
2769 }
2770
2771 static FTH
bn_sub(FTH m,FTH n)2772 bn_sub(FTH m, FTH n)
2773 {
2774 return (fth_make_bignum(bn_math(m, n, BN_SUB)));
2775 }
2776
2777 static FTH
bn_mul(FTH m,FTH n)2778 bn_mul(FTH m, FTH n)
2779 {
2780 return (fth_make_bignum(bn_math(m, n, BN_MUL)));
2781 }
2782
2783 static FTH
bn_div(FTH m,FTH n)2784 bn_div(FTH m, FTH n)
2785 {
2786 return (fth_make_bignum(bn_math(m, n, BN_DIV)));
2787 }
2788
2789 FTH
fth_make_bignum(ficlBignum m)2790 fth_make_bignum(ficlBignum m)
2791 {
2792 FTH self;
2793
2794 self = fth_make_instance(bignum_tag, NULL);
2795 FTH_BIGNUM_OBJECT_SET(self, m);
2796 return (self);
2797 }
2798
2799 static ficlBignum
mpi_new(void)2800 mpi_new(void)
2801 {
2802 ficlBignum bn;
2803
2804 bn = mp_malloc(sizeof(mpi));
2805 mpi_init(bn);
2806 return (bn);
2807 }
2808
2809 static void
mpi_free(ficlBignum bn)2810 mpi_free(ficlBignum bn)
2811 {
2812 mpi_clear(bn);
2813 mp_free(bn);
2814 }
2815
2816 FTH
fth_make_big(FTH m)2817 fth_make_big(FTH m)
2818 {
2819 return (fth_make_bignum(fth_bignum_ref(m)));
2820 }
2821
2822 static void
ficl_bn_dot(ficlVm * vm)2823 ficl_bn_dot(ficlVm *vm)
2824 {
2825 #define h_bn_dot "( numb -- ) number output\n\
2826 1 >bignum bn. => 1\n\
2827 Print bignum number NUMB with space added."
2828 ficlBignum x;
2829 char *str;
2830
2831 FTH_STACK_CHECK(vm, 1, 0);
2832 x = ficlStackPopBignum(vm->dataStack);
2833 str = mpi_getstr(NULL, x, 10);
2834 fth_printf("%s ", str);
2835 mp_free(str);
2836 mpi_free(x);
2837 }
2838
2839 #define N_BIGNUM_FUNC_TEST_ZERO(Name, OP) \
2840 static int \
2841 fth_bn_ ## Name(FTH m) \
2842 { \
2843 int flag; \
2844 \
2845 if (FTH_BIGNUM_P(m)) \
2846 flag = (mpi_cmpi(FTH_BIGNUM_OBJECT(m), 0) OP 0); \
2847 else { \
2848 ficlBignum x; \
2849 \
2850 x = fth_bignum_ref(m); \
2851 flag = (mpi_cmpi(x, 0) OP 0); \
2852 mpi_free(x); \
2853 } \
2854 return (flag); \
2855 } \
2856 static void \
2857 ficl_ ## Name(ficlVm *vm) \
2858 { \
2859 int flag; \
2860 \
2861 FTH_STACK_CHECK(vm, 1, 1); \
2862 flag = fth_bn_ ## Name(fth_pop_ficl_cell(vm)); \
2863 ficlStackPushBoolean(vm->dataStack, flag); \
2864 } \
2865 static char* h_ ## Name = "( x -- f ) x " #OP " 0 => flag (bignum)"
2866
2867 /*-
2868 * build:
2869 * int fth_bn_beqz(FTH m) ... for C fth_number_equal_p etc
2870 * void ficl_beqz(ficlVm *vm) ... for Forth words
2871 */
2872 N_BIGNUM_FUNC_TEST_ZERO(beqz, ==);
2873 N_BIGNUM_FUNC_TEST_ZERO(bnoteqz, !=);
2874 N_BIGNUM_FUNC_TEST_ZERO(blessz, <);
2875 N_BIGNUM_FUNC_TEST_ZERO(bgreaterz, >);
2876 N_BIGNUM_FUNC_TEST_ZERO(blesseqz, <=);
2877 N_BIGNUM_FUNC_TEST_ZERO(bgreatereqz, >=);
2878
2879 #define N_BIGNUM_FUNC_TEST_TWO_OP(Name, OP) \
2880 static int \
2881 fth_bn_ ## Name(FTH m, FTH n) \
2882 { \
2883 int flag; \
2884 \
2885 if (FTH_BIGNUM_P(m)) { \
2886 if (FTH_BIGNUM_P(n)) \
2887 flag = (mpi_cmp(FTH_BIGNUM_OBJECT(m), \
2888 FTH_BIGNUM_OBJECT(n)) OP 0); \
2889 else { \
2890 ficlBignum y; \
2891 \
2892 y = fth_bignum_ref(n); \
2893 flag = (mpi_cmp(FTH_BIGNUM_OBJECT(m), y) OP 0); \
2894 mpi_free(y); \
2895 } \
2896 } else if (FTH_BIGNUM_P(n)) { \
2897 ficlBignum x; \
2898 \
2899 x = fth_bignum_ref(m); \
2900 flag = (mpi_cmp(x, FTH_BIGNUM_OBJECT(n)) OP 0); \
2901 mpi_free(x); \
2902 } else { \
2903 ficlBignum x; \
2904 ficlBignum y; \
2905 \
2906 x = fth_bignum_ref(m); \
2907 y = fth_bignum_ref(n); \
2908 flag = (mpi_cmp(x, y) OP 0); \
2909 mpi_free(x); \
2910 mpi_free(y); \
2911 } \
2912 return (flag); \
2913 } \
2914 static void \
2915 ficl_ ## Name(ficlVm *vm) \
2916 { \
2917 FTH m; \
2918 FTH n; \
2919 int flag; \
2920 \
2921 FTH_STACK_CHECK(vm, 2, 1); \
2922 n = fth_pop_ficl_cell(vm); \
2923 m = fth_pop_ficl_cell(vm); \
2924 flag = fth_bn_ ## Name(m, n); \
2925 ficlStackPushBoolean(vm->dataStack, flag); \
2926 } \
2927 static char* h_ ## Name = "( x y -- f ) x " #OP " y => flag (bignum)"
2928
2929 /*-
2930 * build:
2931 * int fth_bn_beq(FTH m, FTH n) ... for C fth_number_equal_p etc
2932 * void ficl_beq(ficlVm *vm) ... for Forth words
2933 */
2934 N_BIGNUM_FUNC_TEST_TWO_OP(beq, ==);
2935 N_BIGNUM_FUNC_TEST_TWO_OP(bnoteq, !=);
2936 N_BIGNUM_FUNC_TEST_TWO_OP(bless, <);
2937 N_BIGNUM_FUNC_TEST_TWO_OP(bgreater, >);
2938 N_BIGNUM_FUNC_TEST_TWO_OP(blesseq, <=);
2939 N_BIGNUM_FUNC_TEST_TWO_OP(bgreatereq, >=);
2940
2941 #define N_BIGNUM_MATH_FUNC_OP(Name, OP, FName) \
2942 static void \
2943 ficl_ ## Name(ficlVm *vm) \
2944 { \
2945 FTH m; \
2946 FTH n; \
2947 \
2948 FTH_STACK_CHECK(vm, 2, 1); \
2949 n = fth_pop_ficl_cell(vm); \
2950 m = fth_pop_ficl_cell(vm); \
2951 ficlStackPushFTH(vm->dataStack, FName(m, n)); \
2952 } \
2953 static char* h_ ## Name = "( x y -- z ) z = x " #OP " y (bignum)"
2954
2955 N_BIGNUM_MATH_FUNC_OP(badd, +, bn_add);
2956 N_BIGNUM_MATH_FUNC_OP(bsub, -, bn_sub);
2957 N_BIGNUM_MATH_FUNC_OP(bmul, *, bn_mul);
2958 N_BIGNUM_MATH_FUNC_OP(bdiv, /, bn_div);
2959
2960 static void
ficl_bgcd(ficlVm * vm)2961 ficl_bgcd(ficlVm *vm)
2962 {
2963 #define h_bgcd "( x y -- z ) z = gcd(x, y)"
2964 ficlBignum x;
2965 ficlBignum y;
2966 ficlBignum z;
2967
2968 FTH_STACK_CHECK(vm, 2, 1);
2969 z = mpi_new();
2970 y = ficlStackPopBignum(vm->dataStack);
2971 x = ficlStackPopBignum(vm->dataStack);
2972 mpi_gcd(z, x, y);
2973 mpi_free(x);
2974 mpi_free(y);
2975 ficlStackPushBignum(vm->dataStack, z);
2976 }
2977
2978 static void
ficl_blcm(ficlVm * vm)2979 ficl_blcm(ficlVm *vm)
2980 {
2981 #define h_blcm "( x y -- z ) z = lcm(x, y)"
2982 ficlBignum x;
2983 ficlBignum y;
2984 ficlBignum z;
2985
2986 FTH_STACK_CHECK(vm, 2, 1);
2987 z = mpi_new();
2988 y = ficlStackPopBignum(vm->dataStack);
2989 x = ficlStackPopBignum(vm->dataStack);
2990 mpi_lcm(z, x, y);
2991 mpi_free(x);
2992 mpi_free(y);
2993 ficlStackPushBignum(vm->dataStack, z);
2994 }
2995
2996 static void
ficl_bpow(ficlVm * vm)2997 ficl_bpow(ficlVm *vm)
2998 {
2999 #define h_bpow "( x y -- z ) z = x ** y"
3000 ficlBignum x;
3001 ficlUnsigned y;
3002 ficlBignum z;
3003
3004 FTH_STACK_CHECK(vm, 2, 1);
3005 z = mpi_new();
3006 y = ficlStackPopUnsigned(vm->dataStack);
3007 x = ficlStackPopBignum(vm->dataStack);
3008 mpi_pow(z, x, y);
3009 mpi_free(x);
3010 ficlStackPushBignum(vm->dataStack, z);
3011 }
3012
3013 static void
ficl_broot(ficlVm * vm)3014 ficl_broot(ficlVm *vm)
3015 {
3016 #define h_broot "( b1 u -- b2 n ) b2 = root(b1, uth); \
3017 n=1 if exact, n=0 otherwise"
3018 ficlBignum b1;
3019 ficlUnsigned u;
3020 ficlBignum b2;
3021 ficlInteger n;
3022
3023 FTH_STACK_CHECK(vm, 2, 2);
3024 u = ficlStackPopUnsigned(vm->dataStack);
3025 b1 = ficlStackPopBignum(vm->dataStack);
3026 b2 = mpi_new();
3027 n = mpi_root(b2, b1, u);
3028 mpi_free(b1);
3029 ficlStackPushBignum(vm->dataStack, b2);
3030 ficlStackPushInteger(vm->dataStack, n);
3031 }
3032
3033 static void
ficl_bsqrt(ficlVm * vm)3034 ficl_bsqrt(ficlVm *vm)
3035 {
3036 #define h_bsqrt "( b1 -- b2 n ) b2 = sqrt(b1); n=1 if exact, n=0 otherwise"
3037 ficlBignum b1;
3038 ficlBignum b2;
3039 ficlInteger n;
3040
3041 FTH_STACK_CHECK(vm, 1, 2);
3042 b1 = ficlStackPopBignum(vm->dataStack);
3043 b2 = mpi_new();
3044 n = mpi_sqrt(b2, b1);
3045 mpi_free(b1);
3046 ficlStackPushBignum(vm->dataStack, b2);
3047 ficlStackPushInteger(vm->dataStack, n);
3048 }
3049
3050 static void
ficl_bnegate(ficlVm * vm)3051 ficl_bnegate(ficlVm *vm)
3052 {
3053 ficlBignum b1;
3054 ficlBignum b2;
3055
3056 FTH_STACK_CHECK(vm, 1, 1);
3057 b1 = ficlStackPopBignum(vm->dataStack);
3058 b2 = mpi_new();
3059 mpi_neg(b2, b1);
3060 mpi_free(b1);
3061 ficlStackPushBignum(vm->dataStack, b2);
3062 }
3063
3064 static void
ficl_babs(ficlVm * vm)3065 ficl_babs(ficlVm *vm)
3066 {
3067 ficlBignum b1;
3068 ficlBignum b2;
3069
3070 FTH_STACK_CHECK(vm, 1, 1);
3071 b1 = ficlStackPopBignum(vm->dataStack);
3072 b2 = mpi_new();
3073 mpi_abs(b2, b1);
3074 mpi_free(b1);
3075 ficlStackPushBignum(vm->dataStack, b2);
3076 }
3077
3078 static void
ficl_bmin(ficlVm * vm)3079 ficl_bmin(ficlVm *vm)
3080 {
3081 ficlBignum x;
3082 ficlBignum y;
3083
3084 FTH_STACK_CHECK(vm, 2, 1);
3085 y = ficlStackPopBignum(vm->dataStack);
3086 x = ficlStackPopBignum(vm->dataStack);
3087
3088 if (mpi_cmp(x, y) < 0) {
3089 mpi_free(y);
3090 ficlStackPushBignum(vm->dataStack, x);
3091 } else {
3092 mpi_free(x);
3093 ficlStackPushBignum(vm->dataStack, y);
3094 }
3095 }
3096
3097 static void
ficl_bmax(ficlVm * vm)3098 ficl_bmax(ficlVm *vm)
3099 {
3100 ficlBignum x;
3101 ficlBignum y;
3102
3103 FTH_STACK_CHECK(vm, 2, 1);
3104 y = ficlStackPopBignum(vm->dataStack);
3105 x = ficlStackPopBignum(vm->dataStack);
3106
3107 if (mpi_cmp(x, y) >= 0) {
3108 mpi_free(y);
3109 ficlStackPushBignum(vm->dataStack, x);
3110 } else {
3111 mpi_free(x);
3112 ficlStackPushBignum(vm->dataStack, y);
3113 }
3114 }
3115
3116 static void
ficl_btwostar(ficlVm * vm)3117 ficl_btwostar(ficlVm *vm)
3118 {
3119 ficlBignum b1;
3120 ficlBignum b2;
3121
3122 FTH_STACK_CHECK(vm, 1, 1);
3123 b1 = ficlStackPopBignum(vm->dataStack);
3124 b2 = mpi_new();
3125 mpi_ash(b2, b1, 1);
3126 mpi_free(b1);
3127 ficlStackPushBignum(vm->dataStack, b2);
3128 }
3129
3130 static void
ficl_btwoslash(ficlVm * vm)3131 ficl_btwoslash(ficlVm *vm)
3132 {
3133 ficlBignum b1;
3134 ficlBignum b2;
3135
3136 FTH_STACK_CHECK(vm, 1, 1);
3137 b1 = ficlStackPopBignum(vm->dataStack);
3138 b2 = mpi_new();
3139 mpi_ash(b2, b1, -1);
3140 mpi_free(b1);
3141 ficlStackPushBignum(vm->dataStack, b2);
3142 }
3143
3144 static void
ficl_bmod(ficlVm * vm)3145 ficl_bmod(ficlVm *vm)
3146 {
3147 #define h_bmod "( b1 b2 -- b3 ) b3 = b1 % b2"
3148 ficlBignum b1;
3149 ficlBignum b2;
3150 ficlBignum b3;
3151
3152 FTH_STACK_CHECK(vm, 2, 1);
3153 b3 = mpi_new();
3154 b2 = ficlStackPopBignum(vm->dataStack);
3155 b1 = ficlStackPopBignum(vm->dataStack);
3156 mpi_mod(b3, b1, b2);
3157 mpi_free(b1);
3158 mpi_free(b2);
3159 ficlStackPushBignum(vm->dataStack, b3);
3160 }
3161
3162 static void
ficl_bslashmod(ficlVm * vm)3163 ficl_bslashmod(ficlVm *vm)
3164 {
3165 #define h_bslashmod "( b1 b2 -- b3 b4 ) b1 / b2; b3 = remainder; b4 = quotient"
3166 ficlBignum b1;
3167 ficlBignum b2;
3168 ficlBignum b3;
3169 ficlBignum b4;
3170
3171 FTH_STACK_CHECK(vm, 2, 2);
3172 b4 = mpi_new();
3173 b3 = mpi_new();
3174 b2 = ficlStackPopBignum(vm->dataStack);
3175 b1 = ficlStackPopBignum(vm->dataStack);
3176 mpi_divqr(b4, b3, b1, b2);
3177 mpi_free(b1);
3178 mpi_free(b2);
3179 ficlStackPushBignum(vm->dataStack, b3);
3180 ficlStackPushBignum(vm->dataStack, b4);
3181 }
3182
3183 static void
ficl_blshift(ficlVm * vm)3184 ficl_blshift(ficlVm *vm)
3185 {
3186 #define h_blshift "( b1 n -- b2 ) b2 = b1 * 2^n"
3187 ficlBignum b1;
3188 ficlInteger n;
3189 ficlBignum b2;
3190
3191 FTH_STACK_CHECK(vm, 2, 1);
3192 n = ficlStackPopInteger(vm->dataStack);
3193 b1 = ficlStackPopBignum(vm->dataStack);
3194 b2 = mpi_new();
3195 mpi_ash(b2, b1, n);
3196 mpi_free(b1);
3197 ficlStackPushBignum(vm->dataStack, b2);
3198 }
3199
3200 static void
ficl_brshift(ficlVm * vm)3201 ficl_brshift(ficlVm *vm)
3202 {
3203 #define h_brshift "( b1 n -- b2 ) b2 = b1 / 2^n"
3204 ficlBignum b1;
3205 ficlInteger n;
3206 ficlBignum b2;
3207
3208 FTH_STACK_CHECK(vm, 2, 1);
3209 n = ficlStackPopInteger(vm->dataStack);
3210 b1 = ficlStackPopBignum(vm->dataStack);
3211 b2 = mpi_new();
3212 mpi_ash(b2, b1, -n);
3213 mpi_free(b1);
3214 ficlStackPushBignum(vm->dataStack, b2);
3215 }
3216
3217 /*
3218 * Parse ficlBignum (in base 10) via xedit/lisp/mp.
3219 */
3220 int
ficl_parse_bignum(ficlVm * vm,ficlString s)3221 ficl_parse_bignum(ficlVm *vm, ficlString s)
3222 {
3223 ficlBignum bn;
3224
3225 if (s.length < 10)
3226 return (FICL_FALSE);
3227
3228 bn = mpi_new();
3229 mpi_setstr(bn, s.text, 10);
3230 ficlStackPushBignum(vm->dataStack, bn);
3231
3232 if (vm->state == FICL_VM_STATE_COMPILE)
3233 ficlPrimitiveLiteralIm(vm);
3234
3235 return (FICL_TRUE);
3236 }
3237
3238 /* === RATIO via xedit/lisp/mp === */
3239
3240 #define h_list_of_ratio_functions "\
3241 *** RATIONAL PRIMITIVES ***\n\
3242 ratio? (rational?) make-ratio >ratio\n\
3243 q. rationalize\n\
3244 s>q q>s c>q f>q q>f\n\
3245 q0= q0<> q0< q0> q0<= q0>=\n\
3246 q= q<> q< q> q<= q>=\n\
3247 q+ q- q* q/ 1/q q** (qpow)\n\
3248 qnegate qfloor qceil qabs\n\
3249 and some aliases:\n\
3250 r. 1/r s>r r>s c>r f>r r>f\n\
3251 rnegate rfloor rceil rabs\n\
3252 exact->inexact inexact->exact\n\
3253 numerator denominator"
3254
3255 static void
ficl_ratio_p(ficlVm * vm)3256 ficl_ratio_p(ficlVm *vm)
3257 {
3258 #define h_ratio_p "( obj -- f ) test if OBJ is a rational number\n\
3259 nil ratio? => #f\n\
3260 1/2 ratio? => #t\n\
3261 pi f>r ratio? => #t\n\
3262 Return #t if OBJ is a ratio object, otherwise #f."
3263 FTH obj;
3264
3265 FTH_STACK_CHECK(vm, 1, 1);
3266 obj = fth_pop_ficl_cell(vm);
3267 ficlStackPushBoolean(vm->dataStack, FTH_RATIO_P(obj));
3268 }
3269
3270 #define FTH_RATIO_NUM(Obj) mpr_num(FTH_RATIO_OBJECT(Obj))
3271 #define FTH_RATIO_DEN(Obj) mpr_den(FTH_RATIO_OBJECT(Obj))
3272
3273 static FTH
rt_inspect(FTH self)3274 rt_inspect(FTH self)
3275 {
3276 return (fth_make_string_format("%s: %S",
3277 FTH_INSTANCE_NAME(self), rt_to_string(self)));
3278 }
3279
3280 static FTH
rt_to_string(FTH self)3281 rt_to_string(FTH self)
3282 {
3283 FTH fs;
3284 char *buf;
3285
3286 buf = mpr_getstr(NULL, FTH_RATIO_OBJECT(self), 10);
3287 fs = fth_make_string(buf);
3288 mp_free(buf);
3289 return (fs);
3290 }
3291
3292 static FTH
rt_copy(FTH self)3293 rt_copy(FTH self)
3294 {
3295 ficlRatio res;
3296
3297 res = mpr_new();
3298 mpr_set(res, FTH_RATIO_OBJECT(self));
3299 return (fth_make_rational(res));
3300 }
3301
3302 static FTH
rt_equal_p(FTH self,FTH obj)3303 rt_equal_p(FTH self, FTH obj)
3304 {
3305 int flag;
3306
3307 flag = mpr_cmp(FTH_RATIO_OBJECT(self), FTH_RATIO_OBJECT(obj));
3308 return (BOOL_TO_FTH(flag == 0));
3309 }
3310
3311 static void
rt_free(FTH self)3312 rt_free(FTH self)
3313 {
3314 mpr_free(FTH_RATIO_OBJECT(self));
3315 }
3316
3317 static ficlRatio
mpr_new(void)3318 mpr_new(void)
3319 {
3320 ficlRatio rt;
3321
3322 rt = mp_malloc(sizeof(mpr));
3323 mpr_init(rt);
3324 return (rt);
3325 }
3326
3327 static void
mpr_free(ficlRatio rt)3328 mpr_free(ficlRatio rt)
3329 {
3330 mpr_clear(rt);
3331 mp_free(rt);
3332 }
3333
3334 static FTH
make_rational(ficlBignum num,ficlBignum den)3335 make_rational(ficlBignum num, ficlBignum den)
3336 {
3337 ficlRatio rt;
3338
3339 rt = mpr_new();
3340 mpi_set(mpr_num(rt), num);
3341 mpi_set(mpr_den(rt), den);
3342 mpr_canonicalize(rt);
3343 return (fth_make_rational(rt));
3344 }
3345
3346 FTH
fth_make_rational(ficlRatio rt)3347 fth_make_rational(ficlRatio rt)
3348 {
3349 FTH self;
3350
3351 self = fth_make_instance(ratio_tag, NULL);
3352 FTH_RATIO_OBJECT_SET(self, rt);
3353 return (self);
3354 }
3355
3356 /*
3357 * Return a FTH ration object from NUM and DEN.
3358 */
3359 FTH
fth_make_ratio(FTH num,FTH den)3360 fth_make_ratio(FTH num, FTH den)
3361 {
3362 #define h_make_ratio "( num den -- ratio ) return rational number\n\
3363 123 456 make-ratio => 41/152\n\
3364 355 113 make-ratio => 355/113\n\
3365 Return a new ratio object with numerator NUM and denumerator DEN."
3366 if (den == FTH_ZERO) {
3367 FTH_MATH_ERROR_THROW("denominator 0");
3368 /* NOTREACHED */
3369 return (FTH_FALSE);
3370 }
3371 return (make_rational(fth_bignum_ref(num), fth_bignum_ref(den)));
3372 }
3373
3374 FTH
fth_make_ratio_from_int(ficlInteger num,ficlInteger den)3375 fth_make_ratio_from_int(ficlInteger num, ficlInteger den)
3376 {
3377 ficlRatio rt;
3378
3379 if (den == 0) {
3380 FTH_MATH_ERROR_THROW("denominator 0");
3381 /* NOTREACHED */
3382 return (FTH_FALSE);
3383 }
3384 rt = mpr_new();
3385 mpr_seti(rt, num, den);
3386 return (fth_make_rational(rt));
3387 }
3388
3389 FTH
fth_make_ratio_from_float(ficlFloat f)3390 fth_make_ratio_from_float(ficlFloat f)
3391 {
3392 ficlRatio rt;
3393
3394 rt = mpr_new();
3395 mpr_setd(rt, f);
3396 return (fth_make_rational(rt));
3397 }
3398
3399 static void
ficl_q_dot(ficlVm * vm)3400 ficl_q_dot(ficlVm *vm)
3401 {
3402 #define h_q_dot "( numb -- ) number output\n\
3403 1.5 r. => 3/2\n\
3404 Print rational number NUMB."
3405 FTH obj;
3406
3407 FTH_STACK_CHECK(vm, 1, 0);
3408 obj = fth_pop_ficl_cell(vm);
3409
3410 if (FTH_RATIO_P(obj))
3411 fth_printf("%S ", obj);
3412 else if (FTH_BIGNUM_P(obj))
3413 fth_printf("%S/1 ", obj);
3414 else {
3415 ficlFloat f;
3416
3417 f = fth_float_ref(obj);
3418 fth_printf("%S ", fth_make_ratio_from_float(f));
3419 }
3420 }
3421
3422 static void
ficl_qnegate(ficlVm * vm)3423 ficl_qnegate(ficlVm *vm)
3424 {
3425 ficlRatio r1;
3426 ficlRatio r2;
3427
3428 FTH_STACK_CHECK(vm, 1, 1);
3429 r1 = ficlStackPopRatio(vm->dataStack);
3430 r2 = mpr_new();
3431 mpr_neg(r2, r1);
3432 mpr_free(r1);
3433 ficlStackPushRatio(vm->dataStack, r2);
3434 }
3435
3436 /*
3437 * XXX: Don't remove this function, required by fth.m4 to set
3438 * FTH_HAVE_RATIO=yes.
3439 */
3440 FTH
fth_ratio_floor(FTH rt)3441 fth_ratio_floor(FTH rt)
3442 {
3443 ficlInteger i;
3444
3445 if (FTH_RATIO_P(rt))
3446 i = (ficlInteger) FTH_FLOOR(mpr_getd(FTH_RATIO_OBJECT(rt)));
3447 else
3448 i = fth_int_ref(rt);
3449
3450 return (fth_make_ratio_from_int(i, 1L));
3451 }
3452
3453 static void
ficl_qfloor(ficlVm * vm)3454 ficl_qfloor(ficlVm *vm)
3455 {
3456 #define h_qfloor "( x -- y ) y = floor(x) (ratio, result is int)"
3457 ficlRatio x;
3458 ficlInteger y;
3459
3460 FTH_STACK_CHECK(vm, 1, 1);
3461 x = ficlStackPopRatio(vm->dataStack);
3462 y = (ficlInteger) FTH_FLOOR(mpr_getd(x));
3463 mpr_free(x);
3464 ficlStackPushInteger(vm->dataStack, y);
3465 }
3466
3467 static void
ficl_qceil(ficlVm * vm)3468 ficl_qceil(ficlVm *vm)
3469 {
3470 ficlRatio x;
3471 ficlInteger y;
3472
3473 FTH_STACK_CHECK(vm, 1, 1);
3474 x = ficlStackPopRatio(vm->dataStack);
3475 y = (ficlInteger) FTH_CEIL(mpr_getd(x));
3476 mpr_free(x);
3477 ficlStackPushInteger(vm->dataStack, y);
3478 }
3479
3480 static void
ficl_qabs(ficlVm * vm)3481 ficl_qabs(ficlVm *vm)
3482 {
3483 ficlRatio x;
3484 ficlRatio y;
3485
3486 FTH_STACK_CHECK(vm, 1, 1);
3487 x = ficlStackPopRatio(vm->dataStack);
3488 y = mpr_new();
3489 mpr_abs(y, x);
3490 mpr_free(x);
3491 ficlStackPushRatio(vm->dataStack, y);
3492 }
3493
3494 static void
ficl_qinvert(ficlVm * vm)3495 ficl_qinvert(ficlVm *vm)
3496 {
3497 #define h_qinvert "( x -- y ) y = 1/x (ratio)"
3498 ficlRatio x;
3499 ficlRatio y;
3500
3501 FTH_STACK_CHECK(vm, 1, 1);
3502 x = ficlStackPopRatio(vm->dataStack);
3503 y = mpr_new();
3504 mpr_inv(y, x);
3505 mpr_free(x);
3506 ficlStackPushRatio(vm->dataStack, y);
3507 }
3508
3509 static ficlRatio
rt_math(FTH m,FTH n,int type)3510 rt_math(FTH m, FTH n, int type)
3511 {
3512 ficlRatio x;
3513 ficlRatio y;
3514 ficlRatio z;
3515
3516 x = fth_ratio_ref(m);
3517 y = fth_ratio_ref(n);
3518 z = mpr_new();
3519
3520 switch (type) {
3521 case BN_ADD:
3522 mpr_add(z, x, y);
3523 break;
3524 case BN_SUB:
3525 mpr_sub(z, x, y);
3526 break;
3527 case BN_MUL:
3528 mpr_mul(z, x, y);
3529 break;
3530 case BN_DIV:
3531 default:
3532 mpr_div(z, x, y);
3533 break;
3534 }
3535
3536 mpr_free(x);
3537 mpr_free(y);
3538 return (z);
3539 }
3540
3541 static FTH
rt_add(FTH m,FTH n)3542 rt_add(FTH m, FTH n)
3543 {
3544 return (fth_make_rational(rt_math(m, n, BN_ADD)));
3545 }
3546
3547 static FTH
rt_sub(FTH m,FTH n)3548 rt_sub(FTH m, FTH n)
3549 {
3550 return (fth_make_rational(rt_math(m, n, BN_SUB)));
3551 }
3552
3553 static FTH
rt_mul(FTH m,FTH n)3554 rt_mul(FTH m, FTH n)
3555 {
3556 return (fth_make_rational(rt_math(m, n, BN_MUL)));
3557 }
3558
3559 static FTH
rt_div(FTH m,FTH n)3560 rt_div(FTH m, FTH n)
3561 {
3562 return (fth_make_rational(rt_math(m, n, BN_DIV)));
3563 }
3564
3565 #define N_RATIO_FUNC_TEST_ZERO(Name, OP) \
3566 static int \
3567 fth_rt_ ## Name(FTH m) \
3568 { \
3569 int flag; \
3570 \
3571 if (FTH_RATIO_P(m)) \
3572 flag = (mpr_cmpi(FTH_RATIO_OBJECT(m), 0) OP 0); \
3573 else if (FTH_BIGNUM_P(m)) \
3574 flag = (mpi_cmpi(FTH_BIGNUM_OBJECT(m), 0) OP 0); \
3575 else { \
3576 ficlRatio x; \
3577 \
3578 x = fth_ratio_ref(m); \
3579 flag = (mpr_cmpi(x, 0) OP 0); \
3580 mpr_free(x); \
3581 } \
3582 return (flag); \
3583 } \
3584 static void \
3585 ficl_ ## Name(ficlVm *vm) \
3586 { \
3587 int flag; \
3588 \
3589 FTH_STACK_CHECK(vm, 1, 1); \
3590 flag = fth_rt_ ## Name(fth_pop_ficl_cell(vm)); \
3591 ficlStackPushBoolean(vm->dataStack, flag); \
3592 } \
3593 static char* h_ ## Name = "( x -- f ) x " #OP " 0 => flag (ratio)"
3594
3595 /*-
3596 * build:
3597 * int fth_rt_qeqz(FTH m) ... for C fth_number_equal_p etc
3598 * void ficl_qeqz(ficlVm *vm) ... for Forth words
3599 */
3600 N_RATIO_FUNC_TEST_ZERO(qeqz, ==);
3601 N_RATIO_FUNC_TEST_ZERO(qnoteqz, !=);
3602 N_RATIO_FUNC_TEST_ZERO(qlessz, <);
3603 N_RATIO_FUNC_TEST_ZERO(qgreaterz, >);
3604 N_RATIO_FUNC_TEST_ZERO(qlesseqz, <=);
3605 N_RATIO_FUNC_TEST_ZERO(qgreatereqz, >=);
3606
3607 #define N_RATIO_FUNC_TEST_TWO_OP(Name, OP) \
3608 static int \
3609 fth_rt_ ## Name(FTH m, FTH n) \
3610 { \
3611 int flag; \
3612 \
3613 if (FTH_RATIO_P(m)) { \
3614 if (FTH_RATIO_P(n)) \
3615 flag = (mpr_cmp(FTH_RATIO_OBJECT(m), \
3616 FTH_RATIO_OBJECT(n)) OP 0); \
3617 else { \
3618 ficlRatio y; \
3619 \
3620 y = fth_ratio_ref(n); \
3621 flag = (mpr_cmp(FTH_RATIO_OBJECT(m), y) OP 0); \
3622 mpr_free(y); \
3623 } \
3624 } else if (FTH_RATIO_P(n)) { \
3625 ficlRatio x; \
3626 \
3627 x = fth_ratio_ref(m); \
3628 flag = (mpr_cmp(x, FTH_RATIO_OBJECT(n)) OP 0); \
3629 mpr_free(x); \
3630 } else { \
3631 ficlRatio x; \
3632 ficlRatio y; \
3633 \
3634 x = fth_ratio_ref(m); \
3635 y = fth_ratio_ref(n); \
3636 flag = (mpr_cmp(x, y) OP 0); \
3637 mpr_free(x); \
3638 mpr_free(y); \
3639 } \
3640 return (flag); \
3641 } \
3642 static void \
3643 ficl_ ## Name(ficlVm *vm) \
3644 { \
3645 FTH m; \
3646 FTH n; \
3647 \
3648 FTH_STACK_CHECK(vm, 2, 1); \
3649 n = fth_pop_ficl_cell(vm); \
3650 m = fth_pop_ficl_cell(vm); \
3651 ficlStackPushBoolean(vm->dataStack, fth_rt_ ## Name(m, n)); \
3652 } \
3653 static char* h_ ## Name = "( x y -- f ) x " #OP " y => flag (ratio)"
3654
3655 /*-
3656 * build:
3657 * int fth_rt_qeq(FTH m, FTH n) ... for C fth_number_equal_p etc
3658 * void ficl_qeq(ficlVm *vm) ... for Forth words
3659 */
3660 N_RATIO_FUNC_TEST_TWO_OP(qeq, ==);
3661 N_RATIO_FUNC_TEST_TWO_OP(qnoteq, !=);
3662 N_RATIO_FUNC_TEST_TWO_OP(qless, <);
3663 N_RATIO_FUNC_TEST_TWO_OP(qgreater, >);
3664 N_RATIO_FUNC_TEST_TWO_OP(qlesseq, <=);
3665 N_RATIO_FUNC_TEST_TWO_OP(qgreatereq, >=);
3666
3667 N_BIGNUM_MATH_FUNC_OP(qadd, +, rt_add);
3668 N_BIGNUM_MATH_FUNC_OP(qsub, -, rt_sub);
3669 N_BIGNUM_MATH_FUNC_OP(qmul, *, rt_mul);
3670 N_BIGNUM_MATH_FUNC_OP(qdiv, /, rt_div);
3671
3672 /*
3673 * Parse ficlRatio (in base 10) via xedit/lisp/mp (1/2, -3/2 etc).
3674 */
3675 int
ficl_parse_ratio(ficlVm * vm,ficlString s)3676 ficl_parse_ratio(ficlVm *vm, ficlString s)
3677 {
3678 ficlRatio rt;
3679
3680 if (s.length < 3)
3681 return (FICL_FALSE);
3682
3683 if (memchr(s.text, '/', s.length) == NULL)
3684 return (FICL_FALSE);
3685
3686 rt = mpr_new();
3687 mpr_setstr(rt, s.text, 10);
3688 ficlStackPushRatio(vm->dataStack, rt);
3689
3690 if (vm->state == FICL_VM_STATE_COMPILE)
3691 ficlPrimitiveLiteralIm(vm);
3692
3693 return (FICL_TRUE);
3694 }
3695
3696 static FTH
number_floor(FTH x)3697 number_floor(FTH x)
3698 {
3699 int type;
3700 ficlFloat f;
3701
3702 if (x == 0 || !FTH_NUMBER_T_P(x)) {
3703 FTH_WRONG_NUMBER_TYPE(x, "a number");
3704 /* NOTREACHED */
3705 return (FTH_FALSE);
3706 }
3707
3708 type = FTH_INSTANCE_TYPE(x);
3709
3710 switch (type) {
3711 case FTH_FLOAT_T:
3712 return (fth_make_float(FTH_FLOOR(FTH_FLOAT_OBJECT(x))));
3713 break;
3714 case FTH_RATIO_T:
3715 f = FTH_FLOOR(mpr_getd(FTH_RATIO_OBJECT(x)));
3716 return (fth_make_ratio_from_float(f));
3717 break;
3718 default:
3719 FTH_WRONG_NUMBER_TYPE(x, "a ficlFloat or ficlRatio");
3720 break;
3721 }
3722
3723 /* NOTREACHED */
3724 return (FTH_FALSE);
3725 }
3726
3727 static FTH
number_inv(FTH x)3728 number_inv(FTH x)
3729 {
3730 int type;
3731 ficlRatio res;
3732
3733 if (x == 0 || !FTH_NUMBER_T_P(x)) {
3734 FTH_WRONG_NUMBER_TYPE(x, "a number");
3735 /* NOTREACHED */
3736 return (FTH_FALSE);
3737 }
3738
3739 type = FTH_INSTANCE_TYPE(x);
3740
3741 switch (type) {
3742 case FTH_RATIO_T:
3743 res = mpr_new();
3744 mpr_inv(res, FTH_RATIO_OBJECT(x));
3745 return (fth_make_rational(res));
3746 break;
3747 case FTH_FLOAT_T:
3748 return (fth_make_float(1.0 / FTH_FLOAT_OBJECT(x)));
3749 break;
3750 default:
3751 FTH_WRONG_NUMBER_TYPE(x, "a ficlFloat or ficlRatio");
3752 break;
3753 }
3754
3755 /* NOTREACHED */
3756 return (FTH_FALSE);
3757 }
3758
3759 /*
3760 * Return inexact number within ERR of X.
3761 */
3762 FTH
fth_rationalize(FTH x,FTH err)3763 fth_rationalize(FTH x, FTH err)
3764 {
3765 if (FTH_INTEGER_P(x))
3766 return (x);
3767
3768 if (FTH_RATIO_P(x) || FTH_INEXACT_P(x)) {
3769 ficlInteger a;
3770 ficlInteger a1;
3771 ficlInteger a2;
3772 ficlInteger b;
3773 ficlInteger b1;
3774 ficlInteger b2;
3775 ficlFloat fex;
3776 ficlFloat er;
3777 FTH ex;
3778 FTH dx;
3779 FTH rx;
3780 FTH tt;
3781 int i;
3782
3783 if (FTH_RATIO_P(x))
3784 ex = x;
3785 else
3786 ex = fth_make_ratio_from_float(fth_float_ref(x));
3787
3788 dx = number_floor(ex);
3789
3790 if (fth_number_equal_p(dx, ex))
3791 return (ex);
3792
3793 a1 = 0;
3794 a2 = 1;
3795 b1 = 1;
3796 b2 = 0;
3797 er = fabs(fth_float_ref(err));
3798 tt = FTH_ONE;
3799 i = 1000000;
3800 ex = fth_number_sub(ex, dx);
3801
3802 if (ex == 0)
3803 return (FTH_ZERO);
3804
3805 rx = number_inv(ex);
3806 fex = FTH_RATIO_REF_FLOAT(ex);
3807
3808 while (--i) {
3809 a = a1 * fth_int_ref(tt) + a2;
3810 b = b1 * fth_int_ref(tt) + b2;
3811
3812 if (b != 0 &&
3813 fabs(fex - (ficlFloat) a / (ficlFloat) b) <= er)
3814 return (fth_number_add(dx,
3815 fth_make_ratio_from_int(a, b)));
3816
3817 rx = number_inv(fth_number_sub(rx, tt));
3818 tt = number_floor(rx);
3819 a2 = a1;
3820 b2 = b1;
3821 a1 = a;
3822 b1 = b;
3823 }
3824 }
3825 return (FTH_ZERO);
3826 }
3827
3828 static void
ficl_rationalize(ficlVm * vm)3829 ficl_rationalize(ficlVm *vm)
3830 {
3831 #define h_rationalize "( x err -- val ) return number within ERR of X\n\
3832 5.2 0.1 rationalize => 5.25\n\
3833 5.4 0.1 rationalize => 5.5\n\
3834 5.23 0.02 rationalize => 5.25\n\
3835 Return inexact number within ERR of X."
3836 FTH x;
3837 FTH err;
3838
3839 FTH_STACK_CHECK(vm, 2, 1);
3840 err = fth_pop_ficl_cell(vm);
3841 x = fth_pop_ficl_cell(vm);
3842
3843 if (FTH_EXACT_P(x) && FTH_EXACT_P(err))
3844 fth_push_ficl_cell(vm, fth_rationalize(x, err));
3845 else {
3846 FTH rt;
3847
3848 rt = fth_rationalize(x, err);
3849 ficlStackPushFTH(vm->dataStack, fth_exact_to_inexact(rt));
3850 }
3851 }
3852
3853 #if HAVE_COMPLEX
3854 #define N_CMP_COMPLEX_OP(Numb1, Numb2, Flag, OP) do { \
3855 ficlComplex x; \
3856 ficlComplex y; \
3857 \
3858 x = fth_complex_ref(Numb1); \
3859 y = fth_complex_ref(Numb2); \
3860 Flag = (creal(x) OP creal(y)); \
3861 \
3862 if (Flag) \
3863 Flag = (cimag(x) OP cimag(y)); \
3864 } while (0)
3865 #else /* !HAVE_COMPLEX */
3866 #define N_CMP_COMPLEX_OP(Numb1, Numb2, Flag, OP)
3867 #endif /* HAVE_COMPLEX */
3868
3869 #define N_CMP_BIGNUM_OP(Numb1, Numb2, Flag, OP, Name) do { \
3870 Flag = fth_bn_b ## Name(Numb1, Numb2); \
3871 } while (0)
3872
3873 #define N_CMP_RATIO_OP(Numb1, Numb2, Flag, OP, Name) do { \
3874 Flag = fth_rt_q ## Name(Numb1, Numb2); \
3875 } while (0)
3876
3877 #define N_CMP_TWO_OP(Numb1, Numb2, Flag, OP, Name) do { \
3878 int type; \
3879 \
3880 type = -1; \
3881 \
3882 if (FTH_NUMBER_T_P(Numb1)) \
3883 type = FTH_INSTANCE_TYPE(Numb1); \
3884 \
3885 if (FTH_NUMBER_T_P(Numb2)) \
3886 type = FICL_MAX(type, (int)FTH_INSTANCE_TYPE(Numb2)); \
3887 \
3888 switch (type) { \
3889 case FTH_FLOAT_T: \
3890 Flag = (fth_float_ref(Numb1) OP fth_float_ref(Numb2)); \
3891 break; \
3892 case FTH_COMPLEX_T: \
3893 N_CMP_COMPLEX_OP(Numb1, Numb2, Flag, OP); \
3894 break; \
3895 case FTH_BIGNUM_T: \
3896 N_CMP_BIGNUM_OP(Numb1, Numb2, Flag, OP, Name); \
3897 break; \
3898 case FTH_RATIO_T: \
3899 N_CMP_RATIO_OP(Numb1, Numb2, Flag, OP, Name); \
3900 break; \
3901 case FTH_LLONG_T: \
3902 Flag = (fth_long_long_ref(Numb1) OP \
3903 fth_long_long_ref(Numb2)); \
3904 break; \
3905 default: \
3906 Flag = (Numb1 OP Numb2); \
3907 break; \
3908 } \
3909 } while (0)
3910
3911 int
fth_number_equal_p(FTH m,FTH n)3912 fth_number_equal_p(FTH m, FTH n)
3913 {
3914 int flag;
3915
3916 if (NUMB_FIXNUM_P(m) && NUMB_FIXNUM_P(n))
3917 return (FIX_TO_INT(m) == FIX_TO_INT(n));
3918
3919 N_CMP_TWO_OP(m, n, flag, ==, eq);
3920 return (flag);
3921 }
3922
3923 int
fth_number_less_p(FTH m,FTH n)3924 fth_number_less_p(FTH m, FTH n)
3925 {
3926 int flag;
3927
3928 if (NUMB_FIXNUM_P(m) && NUMB_FIXNUM_P(n))
3929 return (FIX_TO_INT(m) < FIX_TO_INT(n));
3930
3931 N_CMP_TWO_OP(m, n, flag, <, less);
3932 return (flag);
3933 }
3934
3935 #if HAVE_COMPLEX
3936 #define N_MATH_COMPLEX_OP(N1, N2, OP) \
3937 N1 = fth_make_complex(fth_complex_ref(N1) OP fth_complex_ref(N2))
3938 #else /* !HAVE_COMPLEX */
3939 #define N_MATH_COMPLEX_OP(N1, N2, OP)
3940 #endif /* HAVE_COMPLEX */
3941
3942 #define N_MATH_BIGNUM_OP(Numb1, Numb2, GOP) do { \
3943 Numb1 = bn_ ## GOP(Numb1, Numb2); \
3944 } while (0)
3945
3946 #define N_MATH_RATIO_OP(Numb1, Numb2, GOP) do { \
3947 Numb1 = rt_ ## GOP(Numb1, Numb2); \
3948 } while (0)
3949
3950 #define N_MATH_OP(Numb1, Numb2, OP, GOP) do { \
3951 int type; \
3952 \
3953 type = -1; \
3954 \
3955 if (FTH_NUMBER_T_P(Numb1)) \
3956 type = FTH_INSTANCE_TYPE(Numb1); \
3957 \
3958 if (FTH_NUMBER_T_P(Numb2)) \
3959 type = FICL_MAX(type, (int)FTH_INSTANCE_TYPE(Numb2)); \
3960 \
3961 switch (type) { \
3962 case FTH_FLOAT_T: \
3963 Numb1 = fth_make_float(fth_float_ref(Numb1) OP \
3964 fth_float_ref(Numb2)); \
3965 break; \
3966 case FTH_COMPLEX_T: \
3967 N_MATH_COMPLEX_OP(Numb1, Numb2, OP); \
3968 break; \
3969 case FTH_BIGNUM_T: \
3970 N_MATH_BIGNUM_OP(Numb1, Numb2, GOP); \
3971 break; \
3972 case FTH_RATIO_T: \
3973 N_MATH_RATIO_OP(Numb1, Numb2, GOP); \
3974 break; \
3975 case FTH_LLONG_T: \
3976 Numb1 = fth_make_long_long(fth_long_long_ref(Numb1) OP \
3977 fth_long_long_ref(Numb2)); \
3978 break; \
3979 default: \
3980 Numb1 = Numb1 OP Numb2; \
3981 break; \
3982 } \
3983 } while (0)
3984
3985 FTH
fth_number_add(FTH m,FTH n)3986 fth_number_add(FTH m, FTH n)
3987 {
3988 if (NUMB_FIXNUM_P(m) && NUMB_FIXNUM_P(n))
3989 return (fth_make_int(FIX_TO_INT(m) + FIX_TO_INT(n)));
3990
3991 N_MATH_OP(m, n, +, add);
3992 return (m);
3993 }
3994
3995 FTH
fth_number_sub(FTH m,FTH n)3996 fth_number_sub(FTH m, FTH n)
3997 {
3998 if (NUMB_FIXNUM_P(m) && NUMB_FIXNUM_P(n))
3999 return (fth_make_int(FIX_TO_INT(m) - FIX_TO_INT(n)));
4000
4001 /* suggested from scan-build */
4002 if (m == 0 || n == 0)
4003 return (m);
4004
4005 N_MATH_OP(m, n, -, sub);
4006 return (m);
4007 }
4008
4009 FTH
fth_number_mul(FTH m,FTH n)4010 fth_number_mul(FTH m, FTH n)
4011 {
4012 if (NUMB_FIXNUM_P(m) && NUMB_FIXNUM_P(n))
4013 return (fth_make_int(FIX_TO_INT(m) * FIX_TO_INT(n)));
4014
4015 N_MATH_OP(m, n, *, mul);
4016 return (m);
4017 }
4018
4019 FTH
fth_number_div(FTH m,FTH n)4020 fth_number_div(FTH m, FTH n)
4021 {
4022 if (NUMB_FIXNUM_P(m) && NUMB_FIXNUM_P(n))
4023 return (fth_make_int(FIX_TO_INT(m) / FIX_TO_INT(n)));
4024
4025 N_MATH_OP(m, n, /, div);
4026 return (m);
4027 }
4028
4029 FTH
fth_exact_to_inexact(FTH obj)4030 fth_exact_to_inexact(FTH obj)
4031 {
4032 #define h_exact_to_inexact "( numb1 -- numb2 ) convert to inexact number\n\
4033 3/2 exact->inexact => 1.5\n\
4034 Convert NUMB to an inexact number.\n\
4035 See also inexact->exact."
4036 FTH_ASSERT_ARGS(FTH_NUMBER_P(obj), obj, FTH_ARG1, "a number");
4037 if (FTH_EXACT_P(obj))
4038 return (fth_make_float(fth_float_ref(obj)));
4039 return (obj);
4040 }
4041
4042 FTH
fth_inexact_to_exact(FTH obj)4043 fth_inexact_to_exact(FTH obj)
4044 {
4045 #define h_inexact_to_exact "( numb1 -- numb2 ) convert to exact number\n\
4046 1.5 inexact->exact => 3/2\n\
4047 Convert NUMB to an exact number.\n\
4048 See also exact->inexact."
4049 FTH_ASSERT_ARGS(FTH_NUMBER_P(obj), obj, FTH_ARG1, "a number");
4050 if (FTH_INEXACT_P(obj))
4051 return (fth_make_ratio_from_float(fth_float_ref(obj)));
4052 return (obj);
4053 }
4054
4055 /*
4056 * Return numerator from OBJ or 0.
4057 */
4058 FTH
fth_numerator(FTH obj)4059 fth_numerator(FTH obj)
4060 {
4061 #define h_numerator "( obj -- numerator ) return numerator\n\
4062 3/4 numerator => 3\n\
4063 5 numerator => 5\n\
4064 1.5 numerator => 0\n\
4065 Return numerator of OBJ or 0.\n\
4066 See also denominator."
4067 ficlBignum res;
4068
4069 if (FTH_INTEGER_P(obj))
4070 return (obj);
4071
4072 if (!FTH_RATIO_P(obj))
4073 return (FTH_ZERO);
4074
4075 if (mpi_fiti(FTH_RATIO_NUM(obj))) {
4076 long x;
4077
4078 x = mpi_geti(FTH_RATIO_NUM(obj));
4079 return (fth_make_int(x));
4080 }
4081 res = mpi_new();
4082 mpi_set(res, FTH_RATIO_NUM(obj));
4083 return (fth_make_bignum(res));
4084 }
4085
4086 /*
4087 * Return denominator from OBJ or 1.
4088 */
4089 FTH
fth_denominator(FTH obj)4090 fth_denominator(FTH obj)
4091 {
4092 #define h_denominator "( obj -- denominator ) return denominator\n\
4093 3/4 denominator => 4\n\
4094 5 denominator => 1\n\
4095 1.5 denominator => 1\n\
4096 Return denominator of OBJ or 1.\n\
4097 See also numerator."
4098 ficlBignum res;
4099
4100 if (!FTH_RATIO_P(obj))
4101 return (FTH_ONE);
4102
4103 if (mpi_fiti(FTH_RATIO_DEN(obj))) {
4104 long x;
4105
4106 x = mpi_geti(FTH_RATIO_DEN(obj));
4107 return (fth_make_int(x));
4108 }
4109 res = mpi_new();
4110 mpi_set(res, FTH_RATIO_DEN(obj));
4111 return (fth_make_bignum(res));
4112 }
4113
4114 static void
ficl_odd_p(ficlVm * vm)4115 ficl_odd_p(ficlVm *vm)
4116 {
4117 #define h_odd_p "( numb -- f ) test if NUMB is odd\n\
4118 3 odd? => #t\n\
4119 6 odd? => #f\n\
4120 Return #t if NUMB is odd, otherwise #f.\n\
4121 See also even?"
4122 FTH m;
4123 int flag;
4124
4125 FTH_STACK_CHECK(vm, 1, 1);
4126 m = fth_pop_ficl_cell(vm);
4127 flag = ((fth_int_ref(m) % 2) != 0);
4128 ficlStackPushBoolean(vm->dataStack, flag);
4129 }
4130
4131 static void
ficl_even_p(ficlVm * vm)4132 ficl_even_p(ficlVm *vm)
4133 {
4134 #define h_even_p "( numb -- f ) test if NUMB is even\n\
4135 3 even? => #f\n\
4136 6 even? => #t\n\
4137 Return #t if NUMB is even, otherwise #f.\n\
4138 See also odd?"
4139 FTH m;
4140 int flag;
4141
4142 FTH_STACK_CHECK(vm, 1, 1);
4143 m = fth_pop_ficl_cell(vm);
4144 flag = ((fth_int_ref(m) % 2) == 0);
4145 ficlStackPushBoolean(vm->dataStack, flag);
4146 }
4147
4148 static void
ficl_prime_p(ficlVm * vm)4149 ficl_prime_p(ficlVm *vm)
4150 {
4151 #define h_prime_p "( numb -- f ) test if NUMB is a prime number\n\
4152 3 prime? => #t\n\
4153 123 prime? => #f\n\
4154 Return #t if NUMB is a prime number, otherwise #f."
4155 FTH m;
4156 int flag;
4157 ficl2Integer x;
4158
4159 FTH_STACK_CHECK(vm, 1, 1);
4160 m = fth_pop_ficl_cell(vm);
4161 x = fth_long_long_ref(m);
4162 flag = 0;
4163
4164 if (x == 2)
4165 flag = 1;
4166 else if ((x % 2) != 0) {
4167 int i;
4168
4169 for (i = 3; i < (int) sqrt((double) x); i += 2)
4170 if (((x % i) == 0)) {
4171 flag = 0;
4172 goto finish;
4173 }
4174 flag = 1;
4175 }
4176 finish:
4177 ficlStackPushBoolean(vm->dataStack, flag);
4178 }
4179
4180 /*-
4181 * fesetround(3) may use one of the following constants:
4182 *
4183 * FE_TONEAREST
4184 * FE_DOWNWARD
4185 * FE_UPWARD
4186 * FE_TOWARDZERO
4187 */
4188 #if defined(HAVE_FENV_H)
4189 #include <fenv.h>
4190 #endif
4191
4192 static void
ficl_fegetround(ficlVm * vm)4193 ficl_fegetround(ficlVm *vm)
4194 {
4195 #define h_fegetround "( -- n ) float rounding mode\
4196 Return current floating-point rounding mode, one of:\n\
4197 FE_TONEAREST\n\
4198 FE_DOWNWARD\n\
4199 FE_UPWARD\n\
4200 FE_TOWARDZERO\n\
4201 See also fesetround."
4202 ficlInteger n;
4203
4204 FTH_STACK_CHECK(vm, 0, 1);
4205 #if defined(HAVE_FEGETROUND)
4206 n = fegetround();
4207 #else
4208 n = -1;
4209 #endif
4210 ficlStackPushInteger(vm->dataStack, n);
4211 }
4212
4213 static void
ficl_fesetround(ficlVm * vm)4214 ficl_fesetround(ficlVm *vm)
4215 {
4216 #define h_fesetround "( n -- ) set float rounding mode\
4217 Set current floating-point rounding mode, one of:\n\
4218 FE_TONEAREST\n\
4219 FE_DOWNWARD\n\
4220 FE_UPWARD\n\
4221 FE_TOWARDZERO\n\
4222 See also fegetround."
4223 ficlInteger n;
4224
4225 FTH_STACK_CHECK(vm, 1, 0);
4226 n = ficlStackPopInteger(vm->dataStack);
4227
4228 #if defined(HAVE_FESETROUND)
4229 if (fesetround(n) < 0)
4230 fth_warning("%d not supported, nothing changed", n);
4231 #endif
4232 }
4233
4234 void
init_number_types(void)4235 init_number_types(void)
4236 {
4237 /* init llong */
4238 llong_tag = make_object_number_type(FTH_STR_LLONG,
4239 FTH_LLONG_T, N_EXACT_T);
4240 fth_set_object_inspect(llong_tag, ll_inspect);
4241 fth_set_object_to_string(llong_tag, ll_to_string);
4242 fth_set_object_copy(llong_tag, ll_copy);
4243 fth_set_object_equal_p(llong_tag, ll_equal_p);
4244
4245 /* init float */
4246 float_tag = make_object_number_type(FTH_STR_FLOAT,
4247 FTH_FLOAT_T, N_INEXACT_T);
4248 fth_set_object_inspect(float_tag, fl_inspect);
4249 fth_set_object_to_string(float_tag, fl_to_string);
4250 fth_set_object_copy(float_tag, fl_copy);
4251 fth_set_object_equal_p(float_tag, fl_equal_p);
4252
4253 #if HAVE_COMPLEX
4254 /* complex */
4255 complex_tag = make_object_number_type(FTH_STR_COMPLEX,
4256 FTH_COMPLEX_T, N_INEXACT_T);
4257 fth_set_object_inspect(complex_tag, cp_inspect);
4258 fth_set_object_to_string(complex_tag, cp_to_string);
4259 fth_set_object_copy(complex_tag, cp_copy);
4260 fth_set_object_equal_p(complex_tag, cp_equal_p);
4261 #endif /* HAVE_COMPLEX */
4262
4263 /* init bignum */
4264 bignum_tag = make_object_number_type(FTH_STR_BIGNUM,
4265 FTH_BIGNUM_T, N_EXACT_T);
4266 fth_set_object_inspect(bignum_tag, bn_inspect);
4267 fth_set_object_to_string(bignum_tag, bn_to_string);
4268 fth_set_object_copy(bignum_tag, bn_copy);
4269 fth_set_object_equal_p(bignum_tag, bn_equal_p);
4270 fth_set_object_free(bignum_tag, bn_free);
4271
4272 /* init ratio */
4273 ratio_tag = make_object_number_type(FTH_STR_RATIO,
4274 FTH_RATIO_T, N_EXACT_T);
4275 fth_set_object_inspect(ratio_tag, rt_inspect);
4276 fth_set_object_to_string(ratio_tag, rt_to_string);
4277 fth_set_object_copy(ratio_tag, rt_copy);
4278 fth_set_object_equal_p(ratio_tag, rt_equal_p);
4279 fth_set_object_free(ratio_tag, rt_free);
4280 }
4281
4282 #if defined(HAVE_SYS_TIME_H)
4283 #include <sys/time.h>
4284 #endif
4285 #if defined(HAVE_TIME_H)
4286 #include <time.h>
4287 #endif
4288
4289 void
init_number(void)4290 init_number(void)
4291 {
4292 ficlDictionary *env;
4293 #if !defined(INFINITY)
4294 double tmp, inf;
4295
4296 inf = tmp = 1e+10;
4297 while (1) {
4298 inf *= 1e+10;
4299 if (inf == tmp)
4300 break;
4301 tmp = inf;
4302 }
4303 fth_infinity = inf;
4304 #endif
4305
4306 /* int, llong, rand */
4307 fth_srand((ficlUnsigned) time(NULL));
4308 FTH_PRI1("number?", ficl_number_p, h_number_p);
4309 FTH_PRI1("fixnum?", ficl_fixnum_p, h_fixnum_p);
4310 FTH_PRI1("unsigned?", ficl_unsigned_p, h_unsigned_p);
4311 FTH_PRI1("long-long?", ficl_llong_p, h_llong_p);
4312 FTH_PRI1("off-t?", ficl_llong_p, h_llong_p);
4313 FTH_PRI1("ulong-long?", ficl_ullong_p, h_ullong_p);
4314 FTH_PRI1("uoff-t?", ficl_ullong_p, h_ullong_p);
4315 FTH_PRI1("integer?", ficl_integer_p, h_integer_p);
4316 FTH_PRI1("exact?", ficl_exact_p, h_exact_p);
4317 FTH_PRI1("inexact?", ficl_inexact_p, h_inexact_p);
4318 FTH_PRI1("make-long-long", ficl_to_d, h_to_d);
4319 FTH_PRI1(">llong", ficl_to_d, h_to_d);
4320 FTH_PRI1("make-off-t", ficl_to_d, h_to_d);
4321 FTH_PRI1("make-ulong-long", ficl_to_ud, h_to_ud);
4322 FTH_PRI1("rand-seed-ref", ficl_rand_seed_ref, h_rand_seed_ref);
4323 FTH_PRI1("rand-seed-set!", ficl_rand_seed_set, h_rand_seed_set);
4324 FTH_PRI1("random", ficl_random, h_random);
4325 FTH_PRI1("frandom", ficl_frandom, h_frandom);
4326 FTH_PRI1(".r", ficl_dot_r, h_dot_r);
4327 FTH_PRI1("u.r", ficl_u_dot_r, h_u_dot_r);
4328 FTH_PRI1("d.", ficl_d_dot, h_d_dot);
4329 FTH_PRI1("ud.", ficl_ud_dot, h_ud_dot);
4330 FTH_PRI1("d.r", ficl_d_dot_r, h_d_dot_r);
4331 FTH_PRI1("ud.r", ficl_ud_dot_r, h_ud_dot_r);
4332 FTH_PRI1("u=", ficl_ueq, h_ueq);
4333 FTH_PRI1("u<>", ficl_unoteq, h_unoteq);
4334 FTH_PRI1("u<", ficl_uless, h_uless);
4335 FTH_PRI1("u<=", ficl_ulesseq, h_ulesseq);
4336 FTH_PRI1("u>", ficl_ugreater, h_ugreater);
4337 FTH_PRI1("u>=", ficl_ugreatereq, h_ugreatereq);
4338 FTH_PRI1("s>d", ficl_to_d, h_to_d);
4339 FTH_PRI1("s>ud", ficl_to_ud, h_to_ud);
4340 FTH_PRI1("d>s", ficl_to_s, h_to_s);
4341 FTH_PRI1("f>d", ficl_to_d, h_to_d);
4342 FTH_PRI1("f>ud", ficl_to_ud, h_to_ud);
4343 FTH_PRI1("d>f", ficl_to_f, h_to_f);
4344 FTH_PRI1("dzero?", ficl_dzero, h_dzero);
4345 FTH_PRI1("d0=", ficl_dzero, h_dzero);
4346 FTH_PRI1("d0<>", ficl_dnotz, h_dnotz);
4347 FTH_PRI1("d0<", ficl_dlessz, h_dlessz);
4348 FTH_PRI1("dnegative?", ficl_dlessz, h_dlessz);
4349 FTH_PRI1("d0<=", ficl_dlesseqz, h_dlesseqz);
4350 FTH_PRI1("d0>", ficl_dgreaterz, h_dgreaterz);
4351 FTH_PRI1("d0>=", ficl_dgreatereqz, h_dgreatereqz);
4352 FTH_PRI1("dpositive?", ficl_dgreatereqz, h_dgreatereqz);
4353 FTH_PRI1("d=", ficl_deq, h_deq);
4354 FTH_PRI1("d<>", ficl_dnoteq, h_dnoteq);
4355 FTH_PRI1("d<", ficl_dless, h_dless);
4356 FTH_PRI1("d<=", ficl_dlesseq, h_dlesseq);
4357 FTH_PRI1("d>", ficl_dgreater, h_dgreater);
4358 FTH_PRI1("d>=", ficl_dgreatereq, h_dgreatereq);
4359 FTH_PRI1("du=", ficl_dueq, h_dueq);
4360 FTH_PRI1("du<>", ficl_dunoteq, h_dunoteq);
4361 FTH_PRI1("du<", ficl_duless, h_duless);
4362 FTH_PRI1("du<=", ficl_dulesseq, h_dulesseq);
4363 FTH_PRI1("du>", ficl_dugreater, h_dugreater);
4364 FTH_PRI1("du>=", ficl_dugreatereq, h_dugreatereq);
4365 FTH_PRI1("d+", ficl_dadd, h_dadd);
4366 FTH_PRI1("d-", ficl_dsub, h_dsub);
4367 FTH_PRI1("d*", ficl_dmul, h_dmul);
4368 FTH_PRI1("d/", ficl_ddiv, h_ddiv);
4369 FTH_PRI1("dnegate", ficl_dnegate, h_dnegate);
4370 FTH_PRI1("dabs", ficl_dabs, h_dabs);
4371 FTH_PRI1("dmin", ficl_dmin, h_dmin);
4372 FTH_PRI1("dmax", ficl_dmax, h_dmax);
4373 FTH_PRI1("d2*", ficl_dtwostar, h_dtwostar);
4374 FTH_PRI1("d2/", ficl_dtwoslash, h_dtwoslash);
4375 FTH_ADD_FEATURE_AND_INFO(FTH_STR_LLONG, h_list_of_llong_functions);
4376
4377 /* float */
4378 FTH_PRI1("float?", ficl_float_p, h_float_p);
4379 FTH_PRI1("inf?", ficl_inf_p, h_inf_p);
4380 FTH_PRI1("nan?", ficl_nan_p, h_nan_p);
4381 FTH_PRI1("inf", ficl_inf, h_inf);
4382 FTH_PRI1("nan", ficl_nan, h_nan);
4383 FTH_PRI1("f.r", ficl_f_dot_r, h_f_dot_r);
4384 FTH_PRI1("uf.r", ficl_uf_dot_r, h_uf_dot_r);
4385 FTH_PRI1("floats", ficl_dfloats, h_dfloats);
4386 FTH_PRI1("sfloats", ficl_dfloats, h_dfloats);
4387 FTH_PRI1("dfloats", ficl_dfloats, h_dfloats);
4388 FTH_PRI1("falign", ficl_falign, h_falign);
4389 FTH_PRI1("f>s", ficl_to_s, h_to_s);
4390 FTH_PRI1("s>f", ficl_to_f, h_to_f);
4391 FTH_PRI1("f**", ficl_fpow, h_fpow);
4392 FTH_PRI1("fpow", ficl_fpow, h_fpow);
4393 FTH_PRI1("fabs", ficl_fabs, h_fabs);
4394 #if !HAVE_COMPLEX
4395 FTH_PRI1("magnitude", ficl_fabs, h_fabs);
4396 #endif
4397 FTH_PRI1("fmod", ficl_fmod, h_fmod);
4398 FTH_PRI1("floor", ficl_floor, h_floor);
4399 FTH_PRI1("fceil", ficl_fceil, h_fceil);
4400 FTH_PRI1("ftrunc", ficl_ftrunc, h_ftrunc);
4401 FTH_PRI1("fround", ficl_fround, h_fround);
4402 FTH_PRI1("fsqrt", ficl_fsqrt, h_fsqrt);
4403 FTH_PRI1("fexp", ficl_fexp, h_fexp);
4404 FTH_PRI1("fexpm1", ficl_fexpm1, h_fexpm1);
4405 FTH_PRI1("flog", ficl_flog, h_flog);
4406 FTH_PRI1("flogp1", ficl_flogp1, h_flogp1);
4407 FTH_PRI1("flog1p", ficl_flogp1, h_flogp1);
4408 FTH_PRI1("flog2", ficl_flog2, h_flog2);
4409 FTH_PRI1("flog10", ficl_flog10, h_flog10);
4410 FTH_PRI1("falog", ficl_falog, h_falog);
4411 FTH_PRI1("fsin", ficl_fsin, h_fsin);
4412 FTH_PRI1("fcos", ficl_fcos, h_fcos);
4413 FTH_PRI1("fsincos", ficl_fsincos, h_fsincos);
4414 FTH_PRI1("ftan", ficl_ftan, h_ftan);
4415 FTH_PRI1("fasin", ficl_fasin, h_fasin);
4416 FTH_PRI1("facos", ficl_facos, h_facos);
4417 FTH_PRI1("fatan", ficl_fatan, h_fatan);
4418 FTH_PRI1("fatan2", ficl_fatan2, h_fatan2);
4419 FTH_PRI1("fsinh", ficl_fsinh, h_fsinh);
4420 FTH_PRI1("fcosh", ficl_fcosh, h_fcosh);
4421 FTH_PRI1("ftanh", ficl_ftanh, h_ftanh);
4422 FTH_PRI1("fasinh", ficl_fasinh, h_fasinh);
4423 FTH_PRI1("facosh", ficl_facosh, h_facosh);
4424 FTH_PRI1("fatanh", ficl_fatanh, h_fatanh);
4425
4426 /* math.h */
4427 #if !defined(M_E)
4428 #define M_E 2.7182818284590452354 /* e */
4429 #endif
4430 #if !defined(M_LN2)
4431 #define M_LN2 0.69314718055994530942 /* log(2) */
4432 #endif
4433 #if !defined(M_LN10)
4434 #define M_LN10 2.30258509299404568402 /* log(10) */
4435 #endif
4436 #if !defined(M_PI)
4437 #define M_PI 3.14159265358979323846 /* pi */
4438 #endif
4439 #if !defined(M_PI_2)
4440 #define M_PI_2 1.57079632679489661923 /* pi/2 */
4441 #endif
4442 #if !defined(M_TWO_PI)
4443 #define M_TWO_PI (M_PI * 2.0) /* pi*2 */
4444 #endif
4445 #if !defined(M_SQRT2)
4446 #define M_SQRT2 1.41421356237309504880 /* sqrt(2) */
4447 #endif
4448 fth_define("euler", fth_make_float(M_E));
4449 fth_define("ln-two", fth_make_float(M_LN2));
4450 fth_define("ln-ten", fth_make_float(M_LN10));
4451 fth_define("pi", fth_make_float(M_PI));
4452 fth_define("two-pi", fth_make_float(M_TWO_PI));
4453 fth_define("half-pi", fth_make_float(M_PI_2));
4454 fth_define("sqrt-two", fth_make_float(M_SQRT2));
4455 FTH_ADD_FEATURE_AND_INFO(FTH_STR_FLOAT, h_list_of_float_functions);
4456
4457 /* complex */
4458 FTH_PRI1("complex?", ficl_complex_p, h_complex_p);
4459 FTH_PRI1("real-ref", ficl_creal, h_creal);
4460 FTH_PRI1("imag-ref", ficl_cimage, h_cimage);
4461 FTH_PRI1("image-ref", ficl_cimage, h_cimage);
4462 #if HAVE_COMPLEX
4463 FTH_PRI1("make-rectangular", ficl_make_complex_rectangular,
4464 h_make_complex_rectangular);
4465 FTH_PRI1(">complex", ficl_make_complex_rectangular,
4466 h_make_complex_rectangular);
4467 FTH_PRI1("make-polar", ficl_make_complex_polar,
4468 h_make_complex_polar);
4469 FTH_PRI1("c.", ficl_c_dot, h_c_dot);
4470 FTH_PRI1("s>c", ficl_to_c, h_to_c);
4471 FTH_PRI1("c>s", ficl_to_s, h_to_s);
4472 FTH_PRI1("f>c", ficl_to_c, h_to_c);
4473 FTH_PRI1("c>f", ficl_to_f, h_to_f);
4474 FTH_PRI1("q>c", ficl_to_c, h_to_c);
4475 FTH_PRI1("r>c", ficl_to_c, h_to_c);
4476 FTH_PRI1(">c", ficl_to_c, h_to_c);
4477 FTH_PRI1("c0=", ficl_ceqz, h_ceqz);
4478 FTH_PRI1("c0<>", ficl_cnoteqz, h_cnoteqz);
4479 FTH_PRI1("c=", ficl_ceq, h_ceq);
4480 FTH_PRI1("c<>", ficl_cnoteq, h_cnoteq);
4481 FTH_PRI1("c+", ficl_cadd, h_cadd);
4482 FTH_PRI1("c-", ficl_csub, h_csub);
4483 FTH_PRI1("c*", ficl_cmul, h_cmul);
4484 FTH_PRI1("c/", ficl_cdiv, h_cdiv);
4485 FTH_PRI1("1/c", ficl_creciprocal, h_creciprocal);
4486 FTH_PRI1("carg", ficl_carg, h_carg);
4487 FTH_PRI1("cabs", ficl_cabs, h_cabs);
4488 FTH_PRI1("magnitude", ficl_cabs, h_cabs);
4489 FTH_PRI1("cabs2", ficl_cabs2, h_cabs2);
4490 FTH_PRI1("c**", ficl_cpow, h_cpow);
4491 FTH_PRI1("cpow", ficl_cpow, h_cpow);
4492 FTH_PRI1("conj", ficl_cconj, h_cconj);
4493 FTH_PRI1("conjugate", ficl_cconj, h_cconj);
4494 FTH_PRI1("csqrt", ficl_csqrt, h_csqrt);
4495 FTH_PRI1("cexp", ficl_cexp, h_cexp);
4496 FTH_PRI1("clog", ficl_clog, h_clog);
4497 FTH_PRI1("clog10", ficl_clog10, h_clog10);
4498 FTH_PRI1("csin", ficl_csin, h_csin);
4499 FTH_PRI1("ccos", ficl_ccos, h_ccos);
4500 FTH_PRI1("ctan", ficl_ctan, h_ctan);
4501 FTH_PRI1("casin", ficl_casin, h_casin);
4502 FTH_PRI1("cacos", ficl_cacos, h_cacos);
4503 FTH_PRI1("catan", ficl_catan, h_catan);
4504 FTH_PRI1("catan2", ficl_catan2, h_catan2);
4505 FTH_PRI1("csinh", ficl_csinh, h_csinh);
4506 FTH_PRI1("ccosh", ficl_ccosh, h_ccosh);
4507 FTH_PRI1("ctanh", ficl_ctanh, h_ctanh);
4508 FTH_PRI1("casinh", ficl_casinh, h_casinh);
4509 FTH_PRI1("cacosh", ficl_cacosh, h_cacosh);
4510 FTH_PRI1("catanh", ficl_catanh, h_catanh);
4511 FTH_ADD_FEATURE_AND_INFO(FTH_STR_COMPLEX, h_list_of_complex_functions);
4512 #endif /* HAVE_COMPLEX */
4513
4514 /* bignum */
4515 FTH_PRI1("bignum?", ficl_bignum_p, h_bignum_p);
4516 FTH_PRI1("make-bignum", ficl_to_bn, h_to_bn);
4517 FTH_PRI1(">bignum", ficl_to_bn, h_to_bn);
4518 FTH_PRI1("bn.", ficl_bn_dot, h_bn_dot);
4519 FTH_PRI1("s>b", ficl_to_bn, h_to_bn);
4520 FTH_PRI1("b>s", ficl_to_s, h_to_s);
4521 FTH_PRI1("f>b", ficl_to_bn, h_to_bn);
4522 FTH_PRI1("b>f", ficl_to_f, h_to_f);
4523 FTH_PRI1("b0=", ficl_beqz, h_beqz);
4524 FTH_PRI1("b0<>", ficl_bnoteqz, h_bnoteqz);
4525 FTH_PRI1("b0<", ficl_blessz, h_blessz);
4526 FTH_PRI1("b0>", ficl_bgreaterz, h_bgreaterz);
4527 FTH_PRI1("b0<=", ficl_blesseqz, h_blesseqz);
4528 FTH_PRI1("b0>=", ficl_bgreatereqz, h_bgreatereqz);
4529 FTH_PRI1("b=", ficl_beq, h_beq);
4530 FTH_PRI1("b<>", ficl_bnoteq, h_bnoteq);
4531 FTH_PRI1("b<", ficl_bless, h_bless);
4532 FTH_PRI1("b>", ficl_bgreater, h_bgreater);
4533 FTH_PRI1("b<=", ficl_blesseq, h_blesseq);
4534 FTH_PRI1("b>=", ficl_bgreatereq, h_bgreatereq);
4535 FTH_PRI1("b+", ficl_badd, h_badd);
4536 FTH_PRI1("b-", ficl_bsub, h_bsub);
4537 FTH_PRI1("b*", ficl_bmul, h_bmul);
4538 FTH_PRI1("b/", ficl_bdiv, h_bdiv);
4539 FTH_PRI1("bgcd", ficl_bgcd, h_bgcd);
4540 FTH_PRI1("blcm", ficl_blcm, h_blcm);
4541 FTH_PRI1("b**", ficl_bpow, h_bpow);
4542 FTH_PRI1("bpow", ficl_bpow, h_bpow);
4543 FTH_PRI1("broot", ficl_broot, h_broot);
4544 FTH_PRI1("bsqrt", ficl_bsqrt, h_bsqrt);
4545 FTH_PRI1("bnegate", ficl_bnegate, h_dnegate);
4546 FTH_PRI1("babs", ficl_babs, h_dabs);
4547 FTH_PRI1("bmin", ficl_bmin, h_dmin);
4548 FTH_PRI1("bmax", ficl_bmax, h_dmax);
4549 FTH_PRI1("b2*", ficl_btwostar, h_dtwostar);
4550 FTH_PRI1("b2/", ficl_btwoslash, h_dtwoslash);
4551 FTH_PRI1("bmod", ficl_bmod, h_bmod);
4552 FTH_PRI1("b/mod", ficl_bslashmod, h_bslashmod);
4553 FTH_PRI1("blshift", ficl_blshift, h_blshift);
4554 FTH_PRI1("brshift", ficl_brshift, h_brshift);
4555 FTH_ADD_FEATURE_AND_INFO(FTH_STR_BIGNUM, h_list_of_bignum_functions);
4556
4557 /* ratio */
4558 FTH_PRI1("ratio?", ficl_ratio_p, h_ratio_p);
4559 FTH_PRI1("rational?", ficl_ratio_p, h_ratio_p);
4560 FTH_PROC("make-ratio", fth_make_ratio, 2, 0, 0, h_make_ratio);
4561 FTH_PRI1(">ratio", ficl_to_rt, h_to_rt);
4562 FTH_PRI1("rationalize", ficl_rationalize, h_rationalize);
4563 FTH_PRI1("q.", ficl_q_dot, h_q_dot);
4564 FTH_PRI1("r.", ficl_q_dot, h_q_dot);
4565 FTH_PRI1("s>q", ficl_to_rt, h_to_rt);
4566 FTH_PRI1("s>r", ficl_to_rt, h_to_rt);
4567 FTH_PRI1("q>s", ficl_to_s, h_to_s);
4568 FTH_PRI1("r>s", ficl_to_s, h_to_s);
4569 FTH_PRI1("c>q", ficl_to_rt, h_to_rt);
4570 FTH_PRI1("c>r", ficl_to_rt, h_to_rt);
4571 FTH_PRI1("f>q", ficl_to_rt, h_to_rt);
4572 FTH_PRI1("f>r", ficl_to_rt, h_to_rt);
4573 FTH_PRI1("q>f", ficl_to_f, h_to_f);
4574 FTH_PRI1("r>f", ficl_to_f, h_to_f);
4575 FTH_PRI1("q0=", ficl_qeqz, h_qeqz);
4576 FTH_PRI1("q0<>", ficl_qnoteqz, h_qnoteqz);
4577 FTH_PRI1("q0<", ficl_qlessz, h_qlessz);
4578 FTH_PRI1("q0>", ficl_qgreaterz, h_qgreaterz);
4579 FTH_PRI1("q0<=", ficl_qlesseqz, h_qlesseqz);
4580 FTH_PRI1("q0>=", ficl_qgreatereqz, h_qgreatereqz);
4581 FTH_PRI1("q=", ficl_qeq, h_qeq);
4582 FTH_PRI1("q<>", ficl_qnoteq, h_qnoteq);
4583 FTH_PRI1("q<", ficl_qless, h_qless);
4584 FTH_PRI1("q>", ficl_qgreater, h_qgreater);
4585 FTH_PRI1("q<=", ficl_qlesseq, h_qlesseq);
4586 FTH_PRI1("q>=", ficl_qgreatereq, h_qgreatereq);
4587 FTH_PRI1("q+", ficl_qadd, h_qadd);
4588 FTH_PRI1("q-", ficl_qsub, h_qsub);
4589 FTH_PRI1("q*", ficl_qmul, h_qmul);
4590 FTH_PRI1("q/", ficl_qdiv, h_qdiv);
4591 FTH_PRI1("r+", ficl_qadd, h_qadd);
4592 FTH_PRI1("r-", ficl_qsub, h_qsub);
4593 FTH_PRI1("r*", ficl_qmul, h_qmul);
4594 FTH_PRI1("r/", ficl_qdiv, h_qdiv);
4595 FTH_PRI1("q**", ficl_fpow, h_fpow);
4596 FTH_PRI1("qpow", ficl_fpow, h_fpow);
4597 FTH_PRI1("r**", ficl_fpow, h_fpow);
4598 FTH_PRI1("rpow", ficl_fpow, h_fpow);
4599 FTH_PRI1("qnegate", ficl_qnegate, h_dnegate);
4600 FTH_PRI1("rnegate", ficl_qnegate, h_dnegate);
4601 FTH_PRI1("qfloor", ficl_qfloor, h_qfloor);
4602 FTH_PRI1("rfloor", ficl_qfloor, h_qfloor);
4603 FTH_PRI1("qceil", ficl_qceil, h_fceil);
4604 FTH_PRI1("rceil", ficl_qceil, h_fceil);
4605 FTH_PRI1("qabs", ficl_qabs, h_dabs);
4606 FTH_PRI1("rabs", ficl_qabs, h_dabs);
4607 FTH_PRI1("1/q", ficl_qinvert, h_qinvert);
4608 FTH_PRI1("1/r", ficl_qinvert, h_qinvert);
4609 FTH_ADD_FEATURE_AND_INFO(FTH_STR_RATIO, h_list_of_ratio_functions);
4610
4611 FTH_PROC("exact->inexact", fth_exact_to_inexact, 1, 0, 0,
4612 h_exact_to_inexact);
4613 FTH_PROC("inexact->exact", fth_inexact_to_exact, 1, 0, 0,
4614 h_inexact_to_exact);
4615 FTH_PROC("numerator", fth_numerator, 1, 0, 0, h_numerator);
4616 FTH_PROC("denominator", fth_denominator, 1, 0, 0, h_denominator);
4617 FTH_PRI1("odd?", ficl_odd_p, h_odd_p);
4618 FTH_PRI1("even?", ficl_even_p, h_even_p);
4619 FTH_PRI1("prime?", ficl_prime_p, h_prime_p);
4620
4621 /* fenv(3), fegetround(3), fesetround(3) */
4622 FTH_PRI1("fegetround", ficl_fegetround, h_fegetround);
4623 FTH_PRI1("fesetround", ficl_fesetround, h_fesetround);
4624 #if defined(HAVE_FENV_H)
4625 FTH_SET_CONSTANT(FE_TONEAREST);
4626 FTH_SET_CONSTANT(FE_DOWNWARD);
4627 FTH_SET_CONSTANT(FE_UPWARD);
4628 FTH_SET_CONSTANT(FE_TOWARDZERO);
4629 #endif
4630
4631 /* From ficlSystemCompileCore(), ficl/primitive.c */
4632 env = ficlSystemGetEnvironment(FTH_FICL_SYSTEM());
4633 ficlDictionaryAppendConstant(env, "max-n",
4634 (ficlInteger) fth_make_llong(LONG_MAX));
4635 ficlDictionaryAppendConstant(env, "max-u",
4636 (ficlInteger) fth_make_ullong(ULONG_MAX));
4637 ficlDictionaryAppendConstant(env, "max-d",
4638 (ficlInteger) fth_make_llong(LLONG_MAX));
4639 ficlDictionaryAppendConstant(env, "max-ud",
4640 (ficlInteger) fth_make_ullong(ULLONG_MAX));
4641 #if !defined(MAXFLOAT)
4642 #define MAXFLOAT ((ficlFloat)3.40282346638528860e+38)
4643 #endif
4644 ficlDictionaryAppendConstant(env, "max-float",
4645 (ficlInteger) fth_make_float(MAXFLOAT));
4646 }
4647
4648 /*
4649 * numbers.c ends here
4650 */
4651