1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2019 Thomas Mertes */
5 /* */
6 /* This program is free software; you can redistribute it and/or */
7 /* modify it under the terms of the GNU General Public License as */
8 /* published by the Free Software Foundation; either version 2 of */
9 /* the License, or (at your option) any later version. */
10 /* */
11 /* This program is distributed in the hope that it will be useful, */
12 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
13 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
14 /* GNU General Public License for more details. */
15 /* */
16 /* You should have received a copy of the GNU General Public */
17 /* License along with this program; if not, write to the */
18 /* Free Software Foundation, Inc., 51 Franklin Street, */
19 /* Fifth Floor, Boston, MA 02110-1301, USA. */
20 /* */
21 /* Module: Library */
22 /* File: seed7/src/fltlib.c */
23 /* Changes: 1993, 1994, 2008, 2011 - 2016, 2019 Thomas Mertes */
24 /* Content: All primitive actions for the float type. */
25 /* */
26 /********************************************************************/
27
28 #define LOG_FUNCTIONS 0
29 #define VERBOSE_EXCEPTIONS 0
30
31 #include "version.h"
32
33 #include "stdlib.h"
34 #include "stdio.h"
35 #include "string.h"
36 #include "time.h"
37 #include "math.h"
38 #include "float.h"
39 #include "limits.h"
40
41 #include "common.h"
42 #include "data.h"
43 #include "data_rtl.h"
44 #include "heaputl.h"
45 #include "flistutl.h"
46 #include "syvarutl.h"
47 #include "objutl.h"
48 #include "runerr.h"
49 #include "flt_rtl.h"
50
51 #undef EXTERN
52 #define EXTERN
53 #include "fltlib.h"
54
55 typedef union {
56 #if FLOAT_SIZE == 32
57 uint32Type bits;
58 #endif
59 float aFloat;
60 } float2BitsType;
61
62 typedef union {
63 #if DOUBLE_SIZE == 64
64 uint64Type bits;
65 #endif
66 double aDouble;
67 } double2BitsType;
68
69 static const intType minimumTruncArgument =
70 #if TWOS_COMPLEMENT_INTTYPE
71 INTTYPE_MIN;
72 #else
73 INT_SUFFIX(MINIMUM_TRUNC_ARGUMENT);
74 #endif
75
76
77
78 /**
79 * Compute the absolute value of a float number.
80 * @return the absolute value.
81 */
flt_abs(listType arguments)82 objectType flt_abs (listType arguments)
83
84 {
85 double number;
86
87 /* flt_abs */
88 isit_float(arg_1(arguments));
89 number = take_float(arg_1(arguments));
90 if (number < (double) 0.0) {
91 number = -number;
92 } /* if */
93 return bld_float_temp(number);
94 } /* flt_abs */
95
96
97
98 /**
99 * Compute the arc cosine of x; that is the value whose cosine is x.
100 * @return the arc cosine of x in radians. The returned angle is in
101 * the range [0.0, PI].
102 */
flt_acos(listType arguments)103 objectType flt_acos (listType arguments)
104
105 { /* flt_acos */
106 isit_float(arg_1(arguments));
107 return bld_float_temp(
108 acos(take_float(arg_1(arguments))));
109 } /* flt_acos */
110
111
112
113 /**
114 * Add two float numbers.
115 * @return the sum of the two numbers.
116 */
flt_add(listType arguments)117 objectType flt_add (listType arguments)
118
119 { /* flt_add */
120 isit_float(arg_1(arguments));
121 isit_float(arg_3(arguments));
122 return bld_float_temp(
123 (double) take_float(arg_1(arguments)) +
124 (double) take_float(arg_3(arguments)));
125 } /* flt_add */
126
127
128
129 /**
130 * Increment a float 'number' by a 'delta'.
131 */
flt_add_assign(listType arguments)132 objectType flt_add_assign (listType arguments)
133
134 {
135 objectType flt_variable;
136
137 /* flt_add_assign */
138 flt_variable = arg_1(arguments);
139 isit_float(flt_variable);
140 is_variable(flt_variable);
141 isit_float(arg_3(arguments));
142 flt_variable->value.floatValue += take_float(arg_3(arguments));
143 return SYS_EMPTY_OBJECT;
144 } /* flt_add_assign */
145
146
147
148 /**
149 * Compute the arc sine of x; that is the value whose sine is x.
150 * @return the arc sine of x in radians. The return angle is in the
151 * range [-PI/2, PI/2].
152 */
flt_asin(listType arguments)153 objectType flt_asin (listType arguments)
154
155 { /* flt_asin */
156 isit_float(arg_1(arguments));
157 return bld_float_temp(
158 asin(take_float(arg_1(arguments))));
159 } /* flt_asin */
160
161
162
163 /**
164 * Compute the arc tangent of x; that is the value whose tangent is x.
165 * @return the arc tangent of x in radians. The returned angle is in
166 * the range [-PI/2, PI/2].
167 */
flt_atan(listType arguments)168 objectType flt_atan (listType arguments)
169
170 { /* flt_atan */
171 isit_float(arg_1(arguments));
172 return bld_float_temp(
173 atan(take_float(arg_1(arguments))));
174 } /* flt_atan */
175
176
177
178 /**
179 * Compute the arc tangent of y/x.
180 * The signs of x and y are used to determine the quadrant of the result.
181 * It determines the angle theta from the conversion of rectangular
182 * coordinates (x, y) to polar coordinates (r, theta).
183 * @return the arc tangent of y/x in radians. The returned angle is in
184 * the range [-PI, PI].
185 */
flt_atan2(listType arguments)186 objectType flt_atan2 (listType arguments)
187
188 { /* flt_atan2 */
189 isit_float(arg_1(arguments));
190 isit_float(arg_2(arguments));
191 return bld_float_temp(
192 atan2(take_float(arg_1(arguments)), take_float(arg_2(arguments))));
193 } /* flt_atan2 */
194
195
196
197 /**
198 * Get a float from bits in IEEE 754 double-precision representation.
199 * @param bits(arg_1 Bits to be converted to a float.
200 * @return a float from bits in double-precision float representation.
201 */
flt_bits2double(listType arguments)202 objectType flt_bits2double (listType arguments)
203
204 {
205 double2BitsType conv;
206 floatType number;
207
208 /* flt_bits2double */
209 isit_int(arg_1(arguments));
210 conv.bits = (uintType) take_int(arg_1(arguments));
211 number = conv.aDouble;
212 logFunction(printf("flt_bits2double(" FMT_D ") --> " FMT_E "\n",
213 take_int(arg_1(arguments)), number););
214 return bld_float_temp(number);
215 } /* flt_bits2double */
216
217
218
219 /**
220 * Get a float from bits in IEEE 754 single-precision representation.
221 * @param bits/arg_1 Bits to be converted to a float.
222 * @return a float from bits in single-precision float representation.
223 */
flt_bits2single(listType arguments)224 objectType flt_bits2single (listType arguments)
225
226 {
227 intType bits;
228 float2BitsType conv;
229 floatType number;
230
231 /* flt_bits2single */
232 isit_int(arg_1(arguments));
233 bits = take_int(arg_1(arguments));
234 if (unlikely((uintType) bits > UINT32TYPE_MAX)) {
235 logError(printf("flt_bits2single(" FMT_D
236 "): Argument does not fit in 32 bits.\n",
237 bits););
238 return raise_exception(SYS_RNG_EXCEPTION);
239 } else {
240 conv.bits = (uint32Type) bits;
241 number = conv.aFloat;
242 logFunction(printf("flt_bits2single(" FMT_D ") --> " FMT_E "\n",
243 bits, number););
244 return bld_float_temp(number);
245 } /* if */
246 } /* flt_bits2single */
247
248
249
flt_cast(listType arguments)250 objectType flt_cast (listType arguments)
251
252 { /* flt_cast */
253 isit_float(arg_3(arguments));
254 /* The float value is taken as int on purpose */
255 return bld_int_temp(take_int(arg_3(arguments)));
256 } /* flt_cast */
257
258
259
260 /**
261 * Round up towards positive infinity.
262 * Determine the smallest value that is greater than or equal
263 * to the argument and is equal to a mathematical integer.
264 * @return the rounded value.
265 */
flt_ceil(listType arguments)266 objectType flt_ceil (listType arguments)
267
268 { /* flt_ceil */
269 isit_float(arg_1(arguments));
270 return bld_float_temp(
271 ceil(take_float(arg_1(arguments))));
272 } /* flt_ceil */
273
274
275
276 /**
277 * Compare two float numbers.
278 * Because flt_cmp is used to sort float values, a unique
279 * sort sequence of all values is needed. Therefore flt_cmp
280 * considers NaN as equal to itself and greater than Infinity.
281 * Negative zero (-0.0) is considered by flt_cmp to be equal to
282 * positive zero (+0.0). This conforms to the behavior of all
283 * other float comparisons with zero.
284 * @return -1, 0 or 1 if the first argument is considered to be
285 * respectively less than, equal to, or greater than the
286 * second.
287 */
flt_cmp(listType arguments)288 objectType flt_cmp (listType arguments)
289
290 { /* flt_cmp */
291 isit_float(arg_1(arguments));
292 isit_float(arg_2(arguments));
293 return bld_int_temp(
294 fltCmp(take_float(arg_1(arguments)), take_float(arg_2(arguments))));
295 } /* flt_cmp */
296
297
298
299 /**
300 * Compute the cosine of x, where x is given in radians.
301 * @return the trigonometric cosine of an angle.
302 */
flt_cos(listType arguments)303 objectType flt_cos (listType arguments)
304
305 { /* flt_cos */
306 isit_float(arg_1(arguments));
307 return bld_float_temp(
308 cos(take_float(arg_1(arguments))));
309 } /* flt_cos */
310
311
312
313 /**
314 * Compute the hyperbolic cosine of x.
315 * cosh(x) is mathematically defined as: (exp(x) + exp(-x)) / 2.0
316 * @return the hyperbolic cosine.
317 */
flt_cosh(listType arguments)318 objectType flt_cosh (listType arguments)
319
320 { /* flt_cosh */
321 isit_float(arg_1(arguments));
322 return bld_float_temp(
323 cosh(take_float(arg_1(arguments))));
324 } /* flt_cosh */
325
326
327
328 /**
329 * Assign source/arg_3 to dest/arg_1.
330 * A copy function assumes that dest/arg_1 contains a legal value.
331 */
flt_cpy(listType arguments)332 objectType flt_cpy (listType arguments)
333
334 {
335 objectType dest;
336
337 /* flt_cpy */
338 dest = arg_1(arguments);
339 isit_float(dest);
340 is_variable(dest);
341 isit_float(arg_3(arguments));
342 dest->value.floatValue = take_float(arg_3(arguments));
343 return SYS_EMPTY_OBJECT;
344 } /* flt_cpy */
345
346
347
348 /**
349 * Initialize dest/arg_1 and assign source/arg_3 to it.
350 * A create function assumes that the contents of dest/arg_1
351 * is undefined. Create functions can be used to initialize
352 * constants.
353 */
flt_create(listType arguments)354 objectType flt_create (listType arguments)
355
356 { /* flt_create */
357 isit_float(arg_3(arguments));
358 SET_CATEGORY_OF_OBJ(arg_1(arguments), FLOATOBJECT);
359 arg_1(arguments)->value.floatValue = take_float(arg_3(arguments));
360 return SYS_EMPTY_OBJECT;
361 } /* flt_create */
362
363
364
365 /**
366 * Decompose float into normalized fraction and integral exponent for 2.
367 * If the argument (number) is 0.0, -0.0, Infinity, -Infinity or NaN the
368 * fraction is set to the argument and the exponent is set to 0.
369 * For all other arguments the fraction is set to an absolute value
370 * between 0.5(included) and 1.0(excluded) and the exponent is set such
371 * that number = fraction * 2.0 ** exponent holds.
372 * @param number Number to be decomposed into fraction and exponent.
373 * @return floatElements with fraction and exponent set.
374 */
flt_decompose(listType arguments)375 objectType flt_decompose (listType arguments)
376
377 {
378 objectType fraction_var;
379 objectType exponent_var;
380 floatType number;
381
382 /* flt_decompose */
383 isit_float(arg_1(arguments));
384 fraction_var = arg_2(arguments);
385 isit_float(fraction_var);
386 is_variable(fraction_var);
387 exponent_var = arg_3(arguments);
388 isit_int(exponent_var);
389 is_variable(exponent_var);
390 number = take_float(arg_1(arguments));
391 logFunction(printf("flt_decompose(" FMT_E ", ...)\n", number););
392 #if FREXP_FUNCTION_OKAY
393 {
394 int exponent;
395
396 fraction_var->value.floatValue = frexp(number, &exponent);
397 exponent_var->value.intValue = (intType) exponent;
398 }
399 #else
400 fraction_var->value.floatValue =
401 fltDecompose(number, &exponent_var->value.intValue);
402 #endif
403 logFunction(printf("flt_decompose --> " FMT_E ", " FMT_D "\n",
404 fraction_var->value.floatValue,
405 exponent_var->value.intValue););
406 return SYS_EMPTY_OBJECT;
407 } /* flt_decompose */
408
409
410
411 /**
412 * Convert a float to a string in decimal fixed point notation.
413 * The number is rounded to the specified number of digits ('precision').
414 * Halfway cases are rounded away from zero. Except for a 'precision' of
415 * zero the representation has a decimal point and at least one digit
416 * before and after the decimal point. Negative numbers are preceded by
417 * a minus sign (e.g.: "-1.25"). If all digits in the result are 0 a
418 * possible negative sign is omitted.
419 * @param precision/arg_3 Number of digits after the decimal point.
420 * If the 'precision' is zero the decimal point is omitted.
421 * @return the string result of the conversion.
422 * @exception RANGE_ERROR If the 'precision' is negative.
423 * @exception MEMORY_ERROR Not enough memory to represent the result.
424 */
flt_dgts(listType arguments)425 objectType flt_dgts (listType arguments)
426
427 { /* flt_dgts */
428 isit_float(arg_1(arguments));
429 isit_int(arg_3(arguments));
430 return bld_stri_temp(
431 fltDgts(take_float(arg_1(arguments)), take_int(arg_3(arguments))));
432 } /* flt_dgts */
433
434
435
436 /**
437 * Compute the division of two float numbers.
438 * @return the quotient of the division.
439 */
flt_div(listType arguments)440 objectType flt_div (listType arguments)
441
442 {
443 floatType dividend;
444 floatType divisor;
445
446 /* flt_div */
447 isit_float(arg_1(arguments));
448 isit_float(arg_3(arguments));
449 dividend = take_float(arg_1(arguments));
450 divisor = take_float(arg_3(arguments));
451 #if CHECK_FLOAT_DIV_BY_ZERO
452 #if FLOAT_NAN_COMPARISON_OKAY
453 if (divisor == 0.0) {
454 #else
455 if (!os_isnan(divisor) && divisor == 0.0) {
456 #endif
457 if (dividend == 0.0 || os_isnan(dividend)) {
458 return bld_float_temp(NOT_A_NUMBER);
459 } else if ((dividend < 0.0) == fltIsNegativeZero(divisor)) {
460 return bld_float_temp(POSITIVE_INFINITY);
461 } else {
462 return bld_float_temp(NEGATIVE_INFINITY);
463 } /* if */
464 } /* if */
465 #endif
466 return bld_float_temp(((double) dividend) / ((double) divisor));
467 } /* flt_div */
468
469
470
471 /**
472 * Divide a float 'number' by a 'divisor' and assign the result back to 'number'.
473 */
474 objectType flt_div_assign (listType arguments)
475
476 {
477 objectType flt_variable;
478 #if CHECK_FLOAT_DIV_BY_ZERO
479 floatType dividend;
480 #endif
481 floatType divisor;
482
483 /* flt_div_assign */
484 flt_variable = arg_1(arguments);
485 isit_float(flt_variable);
486 is_variable(flt_variable);
487 isit_float(arg_3(arguments));
488 divisor = take_float(arg_3(arguments));
489 #if CHECK_FLOAT_DIV_BY_ZERO
490 #if FLOAT_NAN_COMPARISON_OKAY
491 if (divisor == 0.0) {
492 #else
493 if (!os_isnan(divisor) && divisor == 0.0) {
494 #endif
495 dividend = take_float(flt_variable);
496 if (dividend == 0.0 || os_isnan(dividend)) {
497 flt_variable->value.floatValue = NOT_A_NUMBER;
498 } else if ((dividend < 0.0) == fltIsNegativeZero(divisor)) {
499 flt_variable->value.floatValue = POSITIVE_INFINITY;
500 } else {
501 flt_variable->value.floatValue = NEGATIVE_INFINITY;
502 } /* if */
503 } else {
504 flt_variable->value.floatValue /= divisor;
505 } /* if */
506 #else
507 flt_variable->value.floatValue /= divisor;
508 #endif
509 return SYS_EMPTY_OBJECT;
510 } /* flt_div_assign */
511
512
513
514 /**
515 * Get bits in IEEE 754 double-precision representation from a float.
516 * @param number/arg_1 Float value to be converted to bin64.
517 * @return 64 bits in IEEE 754 double-precision float representation.
518 */
519 objectType flt_double2bits (listType arguments)
520
521 {
522 floatType number;
523 double2BitsType conv;
524 intType bits;
525
526 /* flt_double2bits */
527 isit_float(arg_1(arguments));
528 number = take_float(arg_1(arguments));
529 conv.aDouble = number;
530 bits = (intType) (uintType) conv.bits;
531 logFunction(printf("flt_double2bits(" FMT_E ") --> " FMT_D "\n",
532 number, bits););
533 return bld_int_temp(bits);
534 } /* flt_double2bits */
535
536
537
538 /**
539 * Check if two float numbers are equal.
540 * According to IEEE 754 a NaN is not equal to any float value.
541 * Therefore 'NaN = any_value' and 'any_value = NaN'
542 * always return FALSE. Even 'NaN = NaN' returns FALSE.
543 * @return TRUE if both numbers are equal, FALSE otherwise.
544 */
545 objectType flt_eq (listType arguments)
546
547 { /* flt_eq */
548 isit_float(arg_1(arguments));
549 isit_float(arg_3(arguments));
550 #if FLOAT_COMPARISON_OKAY
551 if (take_float(arg_1(arguments)) ==
552 take_float(arg_3(arguments))) {
553 #else
554 if (fltEq(take_float(arg_1(arguments)),
555 take_float(arg_3(arguments)))) {
556 #endif
557 return SYS_TRUE_OBJECT;
558 } else {
559 return SYS_FALSE_OBJECT;
560 } /* if */
561 } /* flt_eq */
562
563
564
565 /**
566 * Compute Euler's number e raised to the power of x.
567 * @return e raised to the power of x.
568 */
569 objectType flt_exp (listType arguments)
570
571 { /* flt_exp */
572 isit_float(arg_1(arguments));
573 return bld_float_temp(
574 fltExp(take_float(arg_1(arguments))));
575 } /* flt_exp */
576
577
578
579 /**
580 * Compute exp(x) - 1.0 (subtract one from e raised to the power of x).
581 * The result is computed in a way that is accurate even if the value
582 * of x is near zero.
583 * @return exp(x) - 1.0
584 */
585 objectType flt_expm1 (listType arguments)
586
587 { /* flt_expm1 */
588 isit_float(arg_1(arguments));
589 return bld_float_temp(
590 fltExpM1(take_float(arg_1(arguments))));
591 } /* flt_expm1 */
592
593
594
595 /**
596 * Round down towards negative infinity.
597 * Returns the largest value that is less than or equal to the
598 * argument and is equal to a mathematical integer.
599 * @return the rounded value.
600 */
601 objectType flt_floor (listType arguments)
602
603 { /* flt_floor */
604 isit_float(arg_1(arguments));
605 return bld_float_temp(
606 floor(take_float(arg_1(arguments))));
607 } /* flt_floor */
608
609
610
611 /**
612 * Check if 'number1' is greater than or equal to 'number2'.
613 * According to IEEE 754 a NaN is neither less than,
614 * equal to, nor greater than any value, including itself.
615 * If 'number1' or 'number2' is NaN, the result is FALSE.
616 * @return TRUE if 'number1' is greater than or equal to 'number2',
617 * FALSE otherwise.
618 */
619 objectType flt_ge (listType arguments)
620
621 { /* flt_ge */
622 isit_float(arg_1(arguments));
623 isit_float(arg_3(arguments));
624 #if FLOAT_COMPARISON_OKAY
625 if (take_float(arg_1(arguments)) >=
626 take_float(arg_3(arguments))) {
627 #else
628 if (fltGe(take_float(arg_1(arguments)),
629 take_float(arg_3(arguments)))) {
630 #endif
631 return SYS_TRUE_OBJECT;
632 } else {
633 return SYS_FALSE_OBJECT;
634 } /* if */
635 } /* flt_ge */
636
637
638
639 /**
640 * Check if 'number1' is greater than 'number2'.
641 * According to IEEE 754 a NaN is neither less than,
642 * equal to, nor greater than any value, including itself.
643 * If 'number1' or 'number2' is NaN, the result is FALSE.
644 * @return TRUE if 'number1' is greater than 'number2',
645 * FALSE otherwise.
646 */
647 objectType flt_gt (listType arguments)
648
649 { /* flt_gt */
650 isit_float(arg_1(arguments));
651 isit_float(arg_3(arguments));
652 #if FLOAT_COMPARISON_OKAY
653 if (take_float(arg_1(arguments)) >
654 take_float(arg_3(arguments))) {
655 #else
656 if (fltGt(take_float(arg_1(arguments)),
657 take_float(arg_3(arguments)))) {
658 #endif
659 return SYS_TRUE_OBJECT;
660 } else {
661 return SYS_FALSE_OBJECT;
662 } /* if */
663 } /* flt_gt */
664
665
666
667 /**
668 * Compute the hash value of a float number.
669 * @return the hash value.
670 */
671 objectType flt_hashcode (listType arguments)
672
673 { /* flt_hashcode */
674 isit_float(arg_1(arguments));
675 /* The float value is taken as int on purpose */
676 return bld_int_temp(take_int(arg_1(arguments)));
677 } /* flt_hashcode */
678
679
680
681 objectType flt_icast (listType arguments)
682
683 { /* flt_icast */
684 isit_int(arg_3(arguments));
685 /* The int value is taken as float on purpose */
686 return bld_float_temp(take_float(arg_3(arguments)));
687 } /* flt_icast */
688
689
690
691 /**
692 * Convert an integer to a float.
693 * @return the float result of the conversion.
694 */
695 objectType flt_iconv1 (listType arguments)
696
697 { /* flt_iconv1 */
698 isit_int(arg_1(arguments));
699 return bld_float_temp((double) take_int(arg_1(arguments)));
700 } /* flt_iconv1 */
701
702
703
704 /**
705 * Convert an integer to a float.
706 * @return the float result of the conversion.
707 */
708 objectType flt_iconv3 (listType arguments)
709
710 { /* flt_iconv3 */
711 isit_int(arg_3(arguments));
712 return bld_float_temp((double) take_int(arg_3(arguments)));
713 } /* flt_iconv3 */
714
715
716
717 /**
718 * Compute the exponentiation of a float 'base' with an integer 'exponent'.
719 * A ** 0 returns 1.0
720 * NaN ** 0 returns 1.0
721 * NaN ** B returns NaN for B <> 0
722 * 0.0 ** B returns 0.0 for B > 0
723 * 0.0 ** 0 returns 1.0
724 * 0.0 ** B returns Infinity for B < 0
725 * (-0.0) ** B returns -Infinity for B < 0 and odd(B)
726 * A ** B returns 1.0 / A ** (-B) for B < 0
727 * @return the result of the exponentiation.
728 */
729 objectType flt_ipow (listType arguments)
730
731 { /* flt_ipow */
732 isit_float(arg_1(arguments));
733 isit_int(arg_3(arguments));
734 return bld_float_temp(
735 fltIPow(take_float(arg_1(arguments)), take_int(arg_3(arguments))));
736 } /* flt_ipow */
737
738
739
740 /**
741 * Determine if a number has a Not-a-Number (NaN) value.
742 * NaN represents an undefined or unrepresentable value.
743 * @return TRUE if the number has a Not-a-Number (NaN) value,
744 * FALSE otherwise.
745 */
746 objectType flt_isnan (listType arguments)
747
748 { /* flt_isnan */
749 isit_float(arg_1(arguments));
750 if (os_isnan(take_float(arg_1(arguments)))) {
751 return SYS_TRUE_OBJECT;
752 } else {
753 return SYS_FALSE_OBJECT;
754 } /* if */
755 } /* flt_isnan */
756
757
758
759 /**
760 * Determine if a number is -0.0.
761 * This function is the only possibility to determine if a number
762 * is -0.0. The comparison operators (=, <>, <, >, <=, >=) and
763 * the function 'compare' treat 0.0 and -0.0 as equal. The
764 * operators ''digits'' and ''sci'' and the function ''str''
765 * return the same [[string]] for -0.0 and +0.0.
766 * @return TRUE if the number is -0.0,
767 * FALSE otherwise.
768 */
769 objectType flt_isnegativezero (listType arguments)
770
771 { /* flt_isnegativezero */
772 isit_float(arg_1(arguments));
773 if (fltIsNegativeZero(take_float(arg_1(arguments)))) {
774 return SYS_TRUE_OBJECT;
775 } else {
776 return SYS_FALSE_OBJECT;
777 } /* if */
778 } /* flt_isnegativezero */
779
780
781
782 /**
783 * Check if 'number1' is less than or equal to 'number2'.
784 * According to IEEE 754 a NaN is neither less than,
785 * equal to, nor greater than any value, including itself.
786 * If 'number1' or 'number2' is NaN, the result is FALSE.
787 * @return TRUE if 'number1' is less than or equal to 'number2',
788 * FALSE otherwise.
789 */
790 objectType flt_le (listType arguments)
791
792 { /* flt_le */
793 isit_float(arg_1(arguments));
794 isit_float(arg_3(arguments));
795 #if FLOAT_COMPARISON_OKAY
796 if (take_float(arg_1(arguments)) <=
797 take_float(arg_3(arguments))) {
798 #else
799 if (fltLe(take_float(arg_1(arguments)),
800 take_float(arg_3(arguments)))) {
801 #endif
802 return SYS_TRUE_OBJECT;
803 } else {
804 return SYS_FALSE_OBJECT;
805 } /* if */
806 } /* flt_le */
807
808
809
810 /**
811 * Return the natural logarithm (base e) of x.
812 * @return the natural logarithm of x.
813 */
814 objectType flt_log (listType arguments)
815
816 {
817 floatType logarithm;
818
819 /* flt_log */
820 isit_float(arg_1(arguments));
821 logarithm = fltLog(take_float(arg_1(arguments)));
822 return bld_float_temp(logarithm);
823 } /* flt_log */
824
825
826
827 /**
828 * Returns the base 10 logarithm of x.
829 * @return the base 10 logarithm of x.
830 */
831 objectType flt_log10 (listType arguments)
832
833 {
834 floatType logarithm;
835
836 /* flt_log10 */
837 isit_float(arg_1(arguments));
838 logarithm = fltLog10(take_float(arg_1(arguments)));
839 return bld_float_temp(logarithm);
840 } /* flt_log10 */
841
842
843
844 /**
845 * Compute log(1.0 + x) (natural logarithm of the sum of 1 and x).
846 * The result is computed in a way that is accurate even if the value
847 * of x is near zero.
848 * @return log(1.0 + x)
849 */
850 objectType flt_log1p (listType arguments)
851
852 {
853 floatType logarithm;
854
855 /* flt_log1p */
856 isit_float(arg_1(arguments));
857 logarithm = fltLog1p(take_float(arg_1(arguments)));
858 return bld_float_temp(logarithm);
859 } /* flt_log1p */
860
861
862
863 /**
864 * Returns the base 2 logarithm of x.
865 * @return the base 2 logarithm of x.
866 */
867 objectType flt_log2 (listType arguments)
868
869 {
870 floatType logarithm;
871
872 /* flt_log2 */
873 isit_float(arg_1(arguments));
874 logarithm = fltLog2(take_float(arg_1(arguments)));
875 return bld_float_temp(logarithm);
876 } /* flt_log2 */
877
878
879
880 /**
881 * Multiply number/arg_1 by 2 raised to the power of exponent/arg_3.
882 * In other words: A << B is equivalent to A * 2.0 ** B
883 * If the result underflows zero is returned.
884 * If the result overflows Infinity or -Infinity is returned,
885 * depending on the sign of number/arg_1.
886 * If the argument number/arg_1 is a NaN, Infinity or -Infinity the
887 * unchanged argument is returned.
888 * @return number * 2.0 ** exponent
889 */
890 objectType flt_lshift (listType arguments)
891
892 {
893 intType lshift;
894 floatType shifted;
895
896 /* flt_lshift */
897 isit_float(arg_1(arguments));
898 isit_int(arg_3(arguments));
899 lshift = take_int(arg_3(arguments));
900 logFunction(printf("flt_lshift(" FMT_E ", " FMT_D ")\n",
901 take_float(arg_1(arguments)), lshift););
902 #if INT_SIZE < INTTYPE_SIZE
903 if (unlikely(lshift > INT_MAX)) {
904 lshift = INT_MAX;
905 } else if (unlikely(lshift < INT_MIN)) {
906 lshift = INT_MIN;
907 } /* if */
908 #endif
909 shifted = fltLdexp(take_float(arg_1(arguments)), (int) lshift);
910 logFunction(printf("flt_lshift --> " FMT_E "\n", shifted););
911 return bld_float_temp(shifted);
912 } /* flt_lshift */
913
914
915
916 /**
917 * Check if 'number1' is less than 'number2'.
918 * According to IEEE 754 a NaN is neither less than,
919 * equal to, nor greater than any value, including itself.
920 * If 'number1' or 'number2' is NaN, the result is FALSE.
921 * @return TRUE if 'number1' is less than 'number2',
922 * FALSE otherwise.
923 */
924 objectType flt_lt (listType arguments)
925
926 { /* flt_lt */
927 isit_float(arg_1(arguments));
928 isit_float(arg_3(arguments));
929 #if FLOAT_COMPARISON_OKAY
930 if (take_float(arg_1(arguments)) <
931 take_float(arg_3(arguments))) {
932 #else
933 if (fltLt(take_float(arg_1(arguments)),
934 take_float(arg_3(arguments)))) {
935 #endif
936 return SYS_TRUE_OBJECT;
937 } else {
938 return SYS_FALSE_OBJECT;
939 } /* if */
940 } /* flt_lt */
941
942
943
944 /**
945 * Compute the floating-point modulo of a division.
946 * The modulo has the same sign as the divisor.
947 * The modulo is dividend - floor(dividend / divisor) * divisor
948 * A mod NaN returns NaN
949 * NaN mod B returns NaN
950 * A mod 0.0 returns NaN
951 * Infinity mod B returns NaN
952 * -Infinity mod B returns NaN
953 * 0.0 mod B returns 0.0 for B <> 0.0
954 * A mod Infinity returns A for A > 0
955 * A mod Infinity returns Infinity for A < 0
956 * A mod -Infinity returns A for A < 0
957 * A mod -Infinity returns -Infinity for A > 0
958 * @return the floating-point modulo of the division.
959 */
960 objectType flt_mod (listType arguments)
961
962 { /* flt_mod */
963 isit_float(arg_1(arguments));
964 isit_float(arg_3(arguments));
965 return bld_float_temp(
966 fltMod(take_float(arg_1(arguments)), take_float(arg_3(arguments))));
967 } /* flt_mod */
968
969
970
971 /**
972 * Multiply two float numbers.
973 * @return the product of the two numbers.
974 */
975 objectType flt_mult (listType arguments)
976
977 { /* flt_mult */
978 isit_float(arg_1(arguments));
979 isit_float(arg_3(arguments));
980 return bld_float_temp(
981 (double) take_float(arg_1(arguments)) *
982 (double) take_float(arg_3(arguments)));
983 } /* flt_mult */
984
985
986
987 /**
988 * Multiply a float 'number' by a 'factor' and assign the result back to 'number'.
989 */
990 objectType flt_mult_assign (listType arguments)
991
992 {
993 objectType flt_variable;
994
995 /* flt_mult_assign */
996 flt_variable = arg_1(arguments);
997 isit_float(flt_variable);
998 is_variable(flt_variable);
999 isit_float(arg_3(arguments));
1000 flt_variable->value.floatValue *= take_float(arg_3(arguments));
1001 return SYS_EMPTY_OBJECT;
1002 } /* flt_mult_assign */
1003
1004
1005
1006 /**
1007 * Check if two float numbers are not equal.
1008 * According to IEEE 754 a NaN is not equal to any float value.
1009 * Therefore 'NaN <> any_value' and 'any_value <> NaN'
1010 * always return TRUE. Even 'NaN <> NaN' returns TRUE.
1011 * @return FALSE if both numbers are equal, TRUE otherwise.
1012 */
1013 objectType flt_ne (listType arguments)
1014
1015 { /* flt_ne */
1016 isit_float(arg_1(arguments));
1017 isit_float(arg_3(arguments));
1018 #if FLOAT_COMPARISON_OKAY
1019 if (take_float(arg_1(arguments)) !=
1020 take_float(arg_3(arguments))) {
1021 #else
1022 if (!fltEq(take_float(arg_1(arguments)),
1023 take_float(arg_3(arguments)))) {
1024 #endif
1025 return SYS_TRUE_OBJECT;
1026 } else {
1027 return SYS_FALSE_OBJECT;
1028 } /* if */
1029 } /* flt_ne */
1030
1031
1032
1033 /**
1034 * Minus sign, negate a float 'number'.
1035 * @return the negated value of the number.
1036 */
1037 objectType flt_negate (listType arguments)
1038
1039 { /* flt_negate */
1040 isit_float(arg_2(arguments));
1041 return bld_float_temp(
1042 -take_float(arg_2(arguments)));
1043 } /* flt_negate */
1044
1045
1046
1047 /**
1048 * Convert a string to a float number.
1049 * @return the float result of the conversion.
1050 * @exception RANGE_ERROR If the string contains not a float literal.
1051 */
1052 objectType flt_parse1 (listType arguments)
1053
1054 { /* flt_parse1 */
1055 isit_stri(arg_1(arguments));
1056 return bld_float_temp(
1057 fltParse(take_stri(arg_1(arguments))));
1058 } /* flt_parse1 */
1059
1060
1061
1062 /**
1063 * Plus sign for float numbers.
1064 * @return its operand unchanged.
1065 */
1066 objectType flt_plus (listType arguments)
1067
1068 { /* flt_plus */
1069 isit_float(arg_2(arguments));
1070 return bld_float_temp((double) take_float(arg_2(arguments)));
1071 } /* flt_plus */
1072
1073
1074
1075 /**
1076 * Compute the exponentiation of a float 'base' with a float 'exponent'.
1077 * A ** B returns NaN for A < 0.0 and B is not integer
1078 * A ** 0.0 returns 1.0
1079 * NaN ** 0.0 returns 1.0
1080 * NaN ** B returns NaN for B <> 0.0
1081 * 0.0 ** B returns 0.0 for B > 0.0
1082 * 0.0 ** 0.0 returns 1.0
1083 * 0.0 ** B returns Infinity for B < 0.0
1084 * (-0.0) ** B returns -Infinity for B < 0.0 and odd(B)
1085 * 1.0 ** B returns 1.0
1086 * 1.0 ** NaN returns 1.0
1087 * A ** NaN returns NaN for A <> 1.0
1088 * @return the result of the exponentiation.
1089 */
1090 objectType flt_pow (listType arguments)
1091
1092 {
1093 floatType power;
1094
1095 /* flt_pow */
1096 isit_float(arg_1(arguments));
1097 isit_float(arg_3(arguments));
1098 power = fltPow(take_float(arg_1(arguments)), take_float(arg_3(arguments)));
1099 return bld_float_temp(power);
1100 } /* flt_pow */
1101
1102
1103
1104 /**
1105 * Compute pseudo-random number in the range [low, high).
1106 * The random values are uniform distributed.
1107 * @return the computed pseudo-random number.
1108 * @exception RANGE_ERROR The range is empty (low >= high holds).
1109 */
1110 objectType flt_rand (listType arguments)
1111
1112 { /* flt_rand */
1113 isit_float(arg_1(arguments));
1114 isit_float(arg_2(arguments));
1115 return bld_float_temp(
1116 fltRand(take_float(arg_1(arguments)), take_float(arg_2(arguments))));
1117 } /* flt_rand */
1118
1119
1120
1121 /**
1122 * Compute the floating-point remainder of a division.
1123 * The remainder has the same sign as the dividend.
1124 * The remainder is dividend - flt(trunc(dividend / divisor)) * divisor
1125 * The remainder is computed without a conversion to integer.
1126 * A rem NaN returns NaN
1127 * NaN rem B returns NaN
1128 * A rem 0.0 returns NaN
1129 * Infinity rem B returns NaN
1130 * -Infinity rem B returns NaN
1131 * 0.0 rem B returns 0.0 for B <> 0.0
1132 * A rem Infinity returns A
1133 * @return the floating-point remainder of the division.
1134 */
1135 objectType flt_rem (listType arguments)
1136
1137 { /* flt_rem */
1138 isit_float(arg_1(arguments));
1139 isit_float(arg_3(arguments));
1140 return bld_float_temp(
1141 fltRem(take_float(arg_1(arguments)), take_float(arg_3(arguments))));
1142 } /* flt_rem */
1143
1144
1145
1146 /**
1147 * Round towards the nearest integer.
1148 * Halfway cases are rounded away from zero.
1149 * @return the rounded value.
1150 * @exception RANGE_ERROR If the number is NaN, -Infinity, Infinity,
1151 * or does not fit into an integer.
1152 */
1153 objectType flt_round (listType arguments)
1154
1155 {
1156 floatType number;
1157 intType rounded;
1158
1159 /* flt_round */
1160 isit_float(arg_1(arguments));
1161 number = take_float(arg_1(arguments));
1162 logFunction(printf("flt_round(" FMT_E ")\n", number););
1163 if (unlikely(os_isnan(number) ||
1164 number < (floatType) minimumTruncArgument ||
1165 number > (floatType) INT_SUFFIX(MAXIMUM_TRUNC_ARGUMENT))) {
1166 logError(printf("flt_round(" FMT_E "): "
1167 "Number does not fit into an integer.\n",
1168 number););
1169 return raise_exception(SYS_RNG_EXCEPTION);
1170 } else {
1171 if (number < (floatType) 0.0) {
1172 rounded = (intType) (number - 0.5);
1173 } else {
1174 rounded = (intType) (number + 0.5);
1175 } /* if */
1176 logFunction(printf("flt_round --> " FMT_D "\n", rounded););
1177 return bld_int_temp(rounded);
1178 } /* if */
1179 } /* flt_round */
1180
1181
1182
1183 /**
1184 * Divide number/arg_1 by 2 raised to the power of exponent/arg_3.
1185 * In other words: A >> B is equivalent to A / 2.0 ** B
1186 * If the result underflows zero is returned.
1187 * If the result overflows Infinity or -Infinity is returned,
1188 * depending on the sign of number/arg_1.
1189 * If the argument number/arg_1 is a NaN, Infinity or -Infinity the
1190 * unchanged argument is returned.
1191 * @return number / 2.0 ** exponent
1192 */
1193 objectType flt_rshift (listType arguments)
1194
1195 {
1196 intType rshift;
1197 floatType shifted;
1198
1199 /* flt_rshift */
1200 isit_float(arg_1(arguments));
1201 isit_int(arg_3(arguments));
1202 rshift = take_int(arg_3(arguments));
1203 logFunction(printf("flt_rshift(" FMT_E ", " FMT_D ")\n",
1204 take_float(arg_1(arguments)), rshift););
1205 #if INT_SIZE < INTTYPE_SIZE
1206 if (unlikely(rshift > INT_MAX)) {
1207 rshift = INT_MAX;
1208 } else
1209 #endif
1210 #if INT_SIZE <= INTTYPE_SIZE
1211 if (unlikely(rshift <= INT_MIN)) {
1212 /* Avoid that negating the rshift overflows in */
1213 /* case we have twos complement integers. Changing */
1214 /* the rshift does not change the result. */
1215 rshift = -INT_MAX;
1216 } /* if */
1217 #endif
1218 shifted = fltLdexp(take_float(arg_1(arguments)), (int) -rshift);
1219 logFunction(printf("flt_rshift --> " FMT_E "\n", shifted););
1220 return bld_float_temp(shifted);
1221 } /* flt_rshift */
1222
1223
1224
1225 /**
1226 * Compute the subtraction of two float numbers.
1227 * @return the difference of the two numbers.
1228 */
1229 objectType flt_sbtr (listType arguments)
1230
1231 { /* flt_sbtr */
1232 isit_float(arg_1(arguments));
1233 isit_float(arg_3(arguments));
1234 return bld_float_temp(
1235 (double) take_float(arg_1(arguments)) -
1236 (double) take_float(arg_3(arguments)));
1237 } /* flt_sbtr */
1238
1239
1240
1241 /**
1242 * Decrement a float 'number' by a 'delta'.
1243 */
1244 objectType flt_sbtr_assign (listType arguments)
1245
1246 {
1247 objectType flt_variable;
1248
1249 /* flt_sbtr_assign */
1250 flt_variable = arg_1(arguments);
1251 isit_float(flt_variable);
1252 is_variable(flt_variable);
1253 isit_float(arg_3(arguments));
1254 flt_variable->value.floatValue -= take_float(arg_3(arguments));
1255 return SYS_EMPTY_OBJECT;
1256 } /* flt_sbtr_assign */
1257
1258
1259
1260 /**
1261 * Convert a 'float' number to a [[string]] in scientific notation.
1262 * Scientific notation uses a decimal significand and a decimal exponent.
1263 * The significand has an optional sign and exactly one digit before the
1264 * decimal point. The fractional part of the significand is rounded
1265 * to the specified number of digits ('precision'). Halfway cases are
1266 * rounded away from zero. The fractional part is followed by the
1267 * letter e and an exponent, which is always signed. The value zero is
1268 * never written with a negative sign.
1269 * @param precision/arg_3 Number of digits after the decimal point.
1270 * If the 'precision' is zero the decimal point is omitted.
1271 * @return the string result of the conversion.
1272 * @exception RANGE_ERROR If the 'precision' is negative.
1273 * @exception MEMORY_ERROR Not enough memory to represent the result.
1274 */
1275 objectType flt_sci (listType arguments)
1276
1277 { /* flt_sci */
1278 isit_float(arg_1(arguments));
1279 isit_int(arg_3(arguments));
1280 return bld_stri_temp(
1281 fltSci(take_float(arg_1(arguments)),
1282 take_int(arg_3(arguments))));
1283 } /* flt_sci */
1284
1285
1286
1287 /**
1288 * Compute the sine of x, where x is given in radians.
1289 * @return the trigonometric sine of an angle.
1290 */
1291 objectType flt_sin (listType arguments)
1292
1293 { /* flt_sin */
1294 isit_float(arg_1(arguments));
1295 return bld_float_temp(
1296 sin(take_float(arg_1(arguments))));
1297 } /* flt_sin */
1298
1299
1300
1301 /**
1302 * Get bits in IEEE 754 single-precision representation from a float.
1303 * @param number/arg_1 Float value to be converted to bin32.
1304 * @return 32 bits in IEEE 754 single-precision float representation.
1305 */
1306 objectType flt_single2bits (listType arguments)
1307
1308 {
1309 floatType number;
1310 float2BitsType conv;
1311 intType bits;
1312
1313 /* flt_single2bits */
1314 isit_float(arg_1(arguments));
1315 number = take_float(arg_1(arguments));
1316 conv.aFloat = (float) number;
1317 bits = (intType) (uintType) conv.bits;
1318 logFunction(printf("flt_single2bits(" FMT_E ") --> " FMT_D "\n",
1319 number, bits););
1320 return bld_int_temp(bits);;
1321 } /* flt_single2bits */
1322
1323
1324
1325 /**
1326 * Compute the hyperbolic sine of x.
1327 * sinh(x) is mathematically defined as: (exp(x) - exp(-x)) / 2.0
1328 * @return the hyperbolic sine.
1329 */
1330 objectType flt_sinh (listType arguments)
1331
1332 { /* flt_sinh */
1333 isit_float(arg_1(arguments));
1334 return bld_float_temp(
1335 sinh(take_float(arg_1(arguments))));
1336 } /* flt_sinh */
1337
1338
1339
1340 /**
1341 * Returns the non-negative square root of x.
1342 * @return the square root of x.
1343 */
1344 objectType flt_sqrt (listType arguments)
1345
1346 {
1347 floatType squareRoot;
1348
1349 /* flt_sqrt */
1350 isit_float(arg_1(arguments));
1351 squareRoot = fltSqrt(take_float(arg_1(arguments)));
1352 return bld_float_temp(squareRoot);
1353 } /* flt_sqrt */
1354
1355
1356
1357 /**
1358 * Convert a float number to a string.
1359 * The number is converted to a string with decimal representation.
1360 * The result string has the style [-]ddd.ddd where there is at least
1361 * one digit before and after the decimal point. The number of digits
1362 * after the decimal point is determined automatically. Except for the
1363 * case if there is only one zero digit after the decimal point,
1364 * the last digit is never zero. Negative zero (-0.0) and positive
1365 * zero (+0.0) are both converted to "0.0".
1366 * str(16.125) returns "16.125"
1367 * str(-0.0) returns "0.0"
1368 * str(Infinity) returns "Infinity"
1369 * str(-Infinity) returns "-Infinity"
1370 * str(NaN) returns "NaN"
1371 * @return the string result of the conversion.
1372 * @exception MEMORY_ERROR Not enough memory to represent the result.
1373 */
1374 objectType flt_str (listType arguments)
1375
1376 { /* flt_str */
1377 isit_float(arg_1(arguments));
1378 return bld_stri_temp(
1379 fltStr(take_float(arg_1(arguments))));
1380 } /* flt_str */
1381
1382
1383
1384 /**
1385 * Compute the tangent of x, where x is given in radians.
1386 * @return the trigonometric tangent of an angle.
1387 */
1388 objectType flt_tan (listType arguments)
1389
1390 { /* flt_tan */
1391 isit_float(arg_1(arguments));
1392 return bld_float_temp(
1393 tan(take_float(arg_1(arguments))));
1394 } /* flt_tan */
1395
1396
1397
1398 /**
1399 * Compute the hyperbolic tangent of x.
1400 * tanh(x) is mathematically defined as: sinh(x) / cosh(x)
1401 * @return the hyperbolic tangent.
1402 */
1403 objectType flt_tanh (listType arguments)
1404
1405 { /* flt_tanh */
1406 isit_float(arg_1(arguments));
1407 return bld_float_temp(
1408 tanh(take_float(arg_1(arguments))));
1409 } /* flt_tanh */
1410
1411
1412
1413 /**
1414 * Truncate towards zero.
1415 * The fractional part of a number is discarded.
1416 * @return the nearest integer not larger in absolute value
1417 * than the argument.
1418 * @exception RANGE_ERROR If the number is NaN, -Infinity, Infinity,
1419 * or does not fit into an integer.
1420 */
1421 objectType flt_trunc (listType arguments)
1422
1423 {
1424 floatType number;
1425
1426 /* flt_trunc */
1427 isit_float(arg_1(arguments));
1428 number = take_float(arg_1(arguments));
1429 logFunction(printf("flt_trunc(" FMT_E ")\n", number););
1430 if (unlikely(os_isnan(number) ||
1431 number < (floatType) minimumTruncArgument ||
1432 number > (floatType) INT_SUFFIX(MAXIMUM_TRUNC_ARGUMENT))) {
1433 logError(printf("flt_trunc(" FMT_E "): "
1434 "Number does not fit into an integer.\n",
1435 number););
1436 return raise_exception(SYS_RNG_EXCEPTION);
1437 } else {
1438 logFunction(printf("flt_trunc --> " FMT_D "\n", (intType) number););
1439 return bld_int_temp((intType) number);
1440 } /* if */
1441 } /* flt_trunc */
1442
1443
1444
1445 /**
1446 * Get 'float' value of the object referenced by 'aReference/arg_1'.
1447 * @return the 'float' value of the referenced object.
1448 * @exception RANGE_ERROR If 'aReference/arg_1' is NIL or
1449 * category(aReference) <> FLOATOBJECT holds.
1450 */
1451 objectType flt_value (listType arguments)
1452
1453 {
1454 objectType aReference;
1455
1456 /* flt_value */
1457 isit_reference(arg_1(arguments));
1458 aReference = take_reference(arg_1(arguments));
1459 if (unlikely(aReference == NULL ||
1460 CATEGORY_OF_OBJ(aReference) != FLOATOBJECT)) {
1461 logError(printf("flt_value(");
1462 trace1(aReference);
1463 printf("): Category is not FLOATOBJECT.\n"););
1464 return raise_exception(SYS_RNG_EXCEPTION);
1465 } else {
1466 return bld_float_temp(take_float(aReference));
1467 } /* if */
1468 } /* flt_value */
1469