a68g-conversion.c
1 //! @file a68g-conversion.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! Conversion tables for IEEE platforms.
25
26 #include "a68g.h"
27 #include "a68g-prelude.h"
28 #include "a68g-mp.h"
29 #include "a68g-genie.h"
30 #include "a68g-postulates.h"
31 #include "a68g-parser.h"
32 #include "a68g-options.h"
33 #include "a68g-optimiser.h"
34 #include "a68g-listing.h"
35
36 // A list of 10 ^ 2 ^ n for conversion purposes on IEEE 754 platforms.
37
38 #if (A68_LEVEL >= 3)
39
40 #include "a68g-quad.h"
41
42 //! @brief 10 ** expo
43
44 static DOUBLE_T pow_10_double[] = {
45 10.0q, 100.0q, 1.0e4q, 1.0e8q, 1.0e16q, 1.0e32q, 1.0e64q, 1.0e128q, 1.0e256q, 1.0e512q, 1.0e1024q, 1.0e2048q, 1.0e4096q
46 };
47
48 DOUBLE_T ten_up_double (int expo)
49 {
50 // This way appears sufficiently accurate.
51 DOUBLE_T dbl_expo = 1.0q, *dep;
52 BOOL_T neg_expo;
53 if (expo == 0) {
54 return 1.0q;
55 }
56 neg_expo = (BOOL_T) (expo < 0);
57 if (neg_expo) {
58 expo = -expo;
59 }
60 if (expo > MAX_DOUBLE_EXPO) {
61 expo = 0;
62 errno = EDOM;
63 }
64 ABEND (expo > MAX_DOUBLE_EXPO, ERROR_INVALID_VALUE, __func__);
65 for (dep = pow_10_double; expo != 0; expo >>= 1, dep++) {
66 if (expo & 0x1) {
67 dbl_expo *= *dep;
68 }
69 }
70 return neg_expo ? 1.0q / dbl_expo : dbl_expo;
71 }
72
73 //! @brief ten_up_quad_real
74
75 QUAD_T ten_up_quad_real (int n)
76 {
77 QUAD_T s = QUAD_REAL_TEN, t;
78 unsigned k, m;
79 t = QUAD_REAL_ONE;
80 if (n < 0) {
81 m = -n;
82 if ((sigerr_quad_real (real_cmp_quad_real (&s, &QUAD_REAL_ZERO) == 0, QUAD_REAL_EBADEXP, "pwr_quad_real"))) {
83 return QUAD_REAL_ZERO;
84 }
85 s = div_quad_real (QUAD_REAL_ONE, s);
86 } else {
87 m = n;
88 }
89 if (m != 0) {
90 k = 1;
91 while (1) {
92 if (k & m) {
93 t = mul_quad_real (s, t);
94 }
95 if ((k <<= 1) <= m) {
96 s = mul_quad_real (s, s);
97 } else {
98 break;
99 }
100 }
101 } else {
102 sigerr_quad_real (real_cmp_quad_real (&s, &QUAD_REAL_ZERO) == 0, QUAD_REAL_EBADEXP, "pwr_quad_real");
103 }
104 return t;
105 }
106
107 #endif
108
109 static REAL_T pow_10[] = {
110 10.0, 100.0, 1.0e4, 1.0e8, 1.0e16, 1.0e32, 1.0e64, 1.0e128, 1.0e256
111 };
112
113 //! @brief 10 ** expo
114
115 REAL_T ten_up (int expo)
116 {
117 // This way appears sufficiently accurate.
118 REAL_T dbl_expo = 1.0, *dep;
119 BOOL_T neg_expo = (BOOL_T) (expo < 0);
120 if (neg_expo) {
121 expo = -expo;
122 }
123 ABEND (expo > MAX_REAL_EXPO, ERROR_INVALID_VALUE, __func__);
124 for (dep = pow_10; expo != 0; expo >>= 1, dep++) {
125 if (expo & 0x1) {
126 dbl_expo *= *dep;
127 }
128 }
129 return neg_expo ? 1 / dbl_expo : dbl_expo;
130 }
