rts-mach.c
1 //! @file rts-mach.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-2024 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 //! Machine parameters.
25
26 // These routines are variants/extensions of SLATEC routines.
27 // SLATEC Common Mathematical Library is a FORTRAN 77 library of general purpose
28 // mathematical and statistical routines, developed at US Government research
29 // laboratories and therefore public domain software.
30 // Repository: http://www.netlib.org/slatec/
31
32 #include "a68g.h"
33 #include "a68g-prelude.h"
34 #include "a68g-genie.h"
35 #include "a68g-numbers.h"
36 #include "a68g-double.h"
37
38 int a68g_i32mach (int i)
39 {
40 // Based SLATEC routine I1MACH.
41 switch (i) {
42 // i32mach(1) = the standard input unit.
43 case 1: {
44 return STDIN_FILENO;
45 }
46 // i32mach(2) = the standard output unit.
47 case 2: {
48 return STDOUT_FILENO;
49 }
50 // i32mach(3) = the standard punch unit.
51 case 3: {
52 return STDOUT_FILENO;
53 }
54 // i32mach(4) = the standard error message unit.
55 case 4: {
56 return STDERR_FILENO;
57 }
58 // i32mach(5) = the number of bits per int storage unit.
59 case 5: {
60 return CHAR_BIT * sizeof (int);
61 }
62 // i32mach(6) = the number of characters per int storage unit.
63 case 6: {
64 return sizeof (int);
65 }
66 // i32mach(7) = a, the base.
67 case 7: {
68 return 2;
69 }
70 // i32mach(8) = s, the number of base-a digits.
71 case 8: {
72 return CHAR_BIT * sizeof (int) - 1;
73 }
74 // i32mach(9) = a**s - 1, the largest magnitude.
75 case 9: {
76 return INT_MAX;
77 }
78 // i32mach(10) = b, the base.
79 case 10: {
80 return FLT_RADIX;
81 }
82 // i32mach(11) = t, the number of base-b digits.
83 case 11: {
84 return FLT_MANT_DIG;
85 }
86 // i32mach(12) = emin, the smallest exponent e.
87 case 12: {
88 return FLT_MIN_EXP;
89 }
90 // i32mach(13) = emax, the largest exponent e.
91 case 13: {
92 return FLT_MAX_EXP;
93 }
94 // i32mach(14) = t, the number of base-b digits.
95 case 14: {
96 return DBL_MANT_DIG;
97 }
98 // i32mach(15) = emin, the smallest exponent e.
99 case 15: {
100 return DBL_MIN_EXP;
101 }
102 // i32mach(16) = emax, the largest exponent e.
103 case 16: {
104 return DBL_MAX_EXP;
105 }
106 default: {
107 return 0;
108 }
109 }
110 }
111
112 //! @brief PROC i32mach (INT) INT
113
114 void genie_i32mach (NODE_T *p)
115 {
116 A68_INT i;
117 POP_OBJECT (p, &i, A68_INT);
118 PUSH_VALUE (p, a68g_i32mach (VALUE (&i)), A68_INT);
119 }
120
121 REAL_T a68g_r64mach (int i)
122 {
123 // Based SLATEC routine R1MACH.
124 switch (i) {
125 // r64mach(1) = b**(emin-1), the smallest positive magnitude.
126 case 1: {
127 return DBL_MIN;
128 }
129 // r64mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
130 case 2: {
131 return DBL_MAX;
132 }
133 // r64mach(3) = b**(-t), the smallest relative spacing.
134 case 3: {
135 return 0.5 * DBL_EPSILON;
136 }
137 // r64mach(4) = b**(1-t), the largest relative spacing.
138 case 4: {
139 return DBL_EPSILON;
140 }
141 // r64mach(5) = log10(b)
142 case 5: {
143 return CONST_M_LOG10_2;
144 }
145 // r64mach(6), the minimum exponent in base 10.
146 case 6: {
147 return DBL_MIN_10_EXP;
148 }
149 // r64mach(7), the maximum exponent in base 10.
150 case 7: {
151 return DBL_MAX_10_EXP;
152 }
153 // r64mach(8), the number of significant digits in base 10.
154 case 8: {
155 return DBL_DIG;
156 }
157 // r64mach(9), the number of mantissa bits.
158 case 9: {
159 return DBL_MANT_DIG;
160 }
161 default: {
162 return 0.0;
163 }
164 }
165 }
166
167 //! @brief PROC r64mach (INT) REAL
168
169 void genie_r64mach (NODE_T *p)
170 {
171 A68_INT i;
172 POP_OBJECT (p, &i, A68_INT);
173 PUSH_VALUE (p, a68g_r64mach (VALUE (&i)), A68_REAL);
174 }
175
176 #if (A68_LEVEL >= 3)
177
178 INT_T a68g_i64mach (int i)
179 {
180 // Based SLATEC routine I1MACH.
181 switch (i) {
182 // i64mach(6) = the number of characters per int storage unit.
183 case 6: {
184 return sizeof (INT_T);
185 }
186 // i64mach(9) = a**s - 1, the largest magnitude.
187 case 9: {
188 return LLONG_MAX;
189 }
190 default: {
191 return a68g_i32mach (i);
192 }
193 }
194 }
195
196 //! @brief PROC i64mach (INT) INT
197
198 void genie_i64mach (NODE_T *p)
199 {
200 A68_INT i;
201 POP_OBJECT (p, &i, A68_INT);
202 PUSH_VALUE (p, a68g_i64mach (VALUE (&i)), A68_INT);
203 }
204
205 DOUBLE_T a68g_r128mach (int i)
206 {
207 // Based SLATEC routine D1MACH.
208 switch (i) {
209 // r128mach(1) = b**(emin-1), the smallest positive magnitude.
210 case 1: {
211 return FLT128_MIN;
212 }
213 // r128mach(2) = b**emax*(1 - b**(-t)), the largest magnitude.
214 case 2: {
215 return FLT128_MAX;
216 }
217 // r128mach(3) = b**(-t), the smallest relative spacing.
218 case 3: {
219 return 0.5 * FLT128_EPSILON;
220 }
221 // r128mach(4) = b**(1-t), the largest relative spacing.
222 case 4: {
223 return FLT128_EPSILON;
224 }
225 // r128mach(5) = log10(b)
226 case 5: {
227 return CONST_M_LOG10_2_Q;
228 }
229 // r128mach(6), the minimum exponent in base 10.
230 case 6: {
231 return FLT128_MIN_10_EXP;
232 }
233 // r128mach(7), the maximum exponent in base 10.
234 case 7: {
235 return FLT128_MAX_10_EXP;
236 }
237 // r128mach(8), the number of significant digits in base 10.
238 case 8: {
239 return FLT128_DIG;
240 }
241 // r128mach(9), the number of mantissa bits.
242 case 9: {
243 return FLT128_MANT_DIG;
244 }
245 default: {
246 return 0.0;
247 }
248 }
249 }
250
251 //! @brief PROC r128mach (INT) REAL
252
253 void genie_r128mach (NODE_T *p)
254 {
255 A68_INT i;
256 POP_OBJECT (p, &i, A68_INT);
257 PUSH_VALUE (p, dble (a68g_r128mach (VALUE (&i))), A68_LONG_REAL);
258 }
259
260 #endif
