a68g-double.h
1 //! @file a68g-double.h
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 //! LONG REAL definitions.
25
26 #if !defined (__A68G_DOUBLE_H__)
27 #define __A68G_DOUBLE_H__
28
29 #if (A68_LEVEL >= 3)
30
31 #define MODCHK(p, m, c) (!(MODULAR_MATH (p) && (m == M_LONG_BITS)) && (c))
32
33 #if defined (HAVE_IEEE_754)
34 #define CHECK_DOUBLE_REAL(p, u) PRELUDE_ERROR (!finite_double (u), p, ERROR_INFINITE, M_LONG_REAL)
35 #define CHECK_DOUBLE_COMPLEX(p, u, v)\
36 PRELUDE_ERROR (isinf_double (u), p, ERROR_INFINITE, M_LONG_REAL);\
37 PRELUDE_ERROR (isinf_double (v), p, ERROR_INFINITE, M_LONG_REAL);
38 #else
39 #define CHECK_DOUBLE_REAL(p, u) {;}
40 #define CHECK_DOUBLE_COMPLEX(p, u, v) {;}
41 #endif
42
43 #define LONG_INT_BASE (9223372036854775808.0q)
44 #define HW(z) ((z).u[1])
45 #define LW(z) ((z).u[0])
46 #define D_NEG(d) ((HW(d) & D_SIGN) != 0)
47 #define D_LT(u, v) (HW (u) < HW (v) ? A68_TRUE : (HW (u) == HW (v) ? LW (u) < LW (v) : A68_FALSE))
48
49 #define RADIX (65536)
50 #define RADIX_Q (65536.0q)
51 #define CONST_2_UP_112_Q (5192296858534827628530496329220096.0q)
52
53 #define IS_ZERO(u) (HW (u) == 0 && LW (u) == 0)
54 #define EQ(u, v) (HW (u) == HW (v) && LW (u) == LW (v))
55 #define GT(u, v) (HW (u) != HW (v) ? HW (u) > HW (v) : LW (u) > LW (v))
56 #define GE(u, v) (HW (u) != HW (v) ? HW (u) >= HW (v) : LW (u) >= LW (v))
57
58 #define acos_double acosq
59 #define acosh_double acoshq
60 #define asin_double asinq
61 #define asinh_double asinhq
62 #define atan2_double atan2q
63 #define atan_double atanq
64 #define atanh_double atanhq
65 #define cacos_double cacosq
66 #define cacosh_double cacoshq
67 #define casin_double casinq
68 #define casinh_double casinhq
69 #define catan_double catanq
70 #define catanh_double catanhq
71 #define cbrt_double cbrtq
72 #define ccos_double ccosq
73 #define ccosh_double ccoshq
74 #define cexp_double cexpq
75 #define cimag_double cimagq
76 #define clog_double clogq
77 #define cos_double cosq
78 #define cosh_double coshq
79 #define creal_double crealq
80 #define csin_double csinq
81 #define csinh_double csinhq
82 #define csqrt_double csqrtq
83 #define ctan_double ctanq
84 #define ctanh_double ctanhq
85 #define erfc_double erfcq
86 #define erf_double erfq
87 #define exp_double expq
88 #define fabs_double fabsq
89 #define finite_double finiteq
90 #define floor_double floorq
91 #define fmod_double fmodq
92 #define isinf_double isinfq
93 #define lgamma_double lgammaq
94 #define log10_double log10q
95 #define log_double logq
96 #define pow_double powq
97 #define sin_double sinq
98 #define sinh_double sinhq
99 #define sqrt_double sqrtq
100 #define tan_double tanq
101 #define tanh_double tanhq
102 #define tgamma_double tgammaq
103 #define trunc_double truncq
104
105 #define DBLEQ(z) ((dble_double (A68 (f_entry), (z))).f)
106
107 #define ABSQ(n) ((n) >= 0.0q ? (n) : -(n))
108
109 #define POP_LONG_COMPLEX(p, re, im) {\
110 POP_OBJECT (p, im, A68_LONG_REAL);\
111 POP_OBJECT (p, re, A68_LONG_REAL);\
112 }
113
114 #define set_lw(z, k) {LW(z) = k; HW(z) = 0;}
115 #define set_hw(z, k) {LW(z) = 0; HW(z) = k;}
116 #define set_hwlw(z, h, l) {LW (z) = l; HW (z) = h;}
117 #define D_ZERO(z) (HW (z) == 0 && LW (z) == 0)
118
119 #define add_double(p, m, w, u, v) {\
120 DOUBLE_NUM_T _ww_;\
121 LW (_ww_) = LW (u) + LW (v);\
122 HW (_ww_) = HW (u) + HW (v);\
123 PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) < HW (v)), p, ERROR_MATH, (m));\
124 if (LW (_ww_) < LW (v)) {\
125 HW (_ww_)++;\
126 PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) < 1), p, ERROR_MATH, (m));\
127 }\
128 w = _ww_;\
129 }
130
131 #define sub_double(p, m, w, u, v) {\
132 DOUBLE_NUM_T _ww_;\
133 LW (_ww_) = LW (u) - LW (v);\
134 HW (_ww_) = HW (u) - HW (v);\
135 PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) > HW (u)), p, ERROR_MATH, (m));\
136 if (LW (_ww_) > LW (u)) {\
137 PRELUDE_ERROR (MODCHK (p, m, HW (_ww_) == 0), p, ERROR_MATH, (m));\
138 HW (_ww_)--;\
139 }\
140 w = _ww_;\
141 }
142
143 static inline DOUBLE_NUM_T dble (DOUBLE_T x)
144 {
145 DOUBLE_NUM_T w;
146 w.f = x;
147 return w;
148 }
149
150 static inline int sign_double_int (DOUBLE_NUM_T w)
151 {
152 if (D_NEG (w)) {
153 return -1;
154 } else if (D_ZERO (w)) {
155 return 0;
156 } else {
157 return 1;
158 }
159 }
160
161 static inline int sign_double (DOUBLE_NUM_T w)
162 {
163 if (w.f < 0.0q) {
164 return -1;
165 } else if (w.f == 0.0q) {
166 return 0;
167 } else {
168 return 1;
169 }
170 }
171
172 static inline DOUBLE_NUM_T abs_double_int (DOUBLE_NUM_T z)
173 {
174 DOUBLE_NUM_T w;
175 LW (w) = LW (z);
176 HW (w) = HW (z) & (~D_SIGN);
177 return w;
178 }
179
180 static inline DOUBLE_NUM_T neg_double_int (DOUBLE_NUM_T z)
181 {
182 DOUBLE_NUM_T w;
183 LW (w) = LW (z);
184 if (D_NEG (z)) {
185 HW (w) = HW (z) & (~D_SIGN);
186 } else {
187 HW (w) = HW (z) | D_SIGN;
188 }
189 return w;
190 }
191
192 void m64to128 (DOUBLE_NUM_T *, UNSIGNED_T, UNSIGNED_T);
193 void m128to128 (NODE_T *, MOID_T *, DOUBLE_NUM_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
194 DOUBLE_NUM_T double_udiv (NODE_T *, MOID_T *, DOUBLE_NUM_T, DOUBLE_NUM_T, int);
195 DOUBLE_NUM_T double_uadd (NODE_T *, MOID_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
196 DOUBLE_NUM_T double_usub (NODE_T *, MOID_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
197 DOUBLE_NUM_T double_umul (NODE_T *, MOID_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
198 DOUBLE_NUM_T double_sadd (NODE_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
199 DOUBLE_NUM_T double_ssub (NODE_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
200 DOUBLE_NUM_T double_smul (NODE_T *, DOUBLE_NUM_T, DOUBLE_NUM_T);
201 DOUBLE_NUM_T double_sdiv (NODE_T *, DOUBLE_NUM_T, DOUBLE_NUM_T, int);
202
203 int sign_double_int (DOUBLE_NUM_T);
204 int sign_double (DOUBLE_NUM_T);
205 int string_to_double_int (NODE_T *, A68_LONG_INT *, char *);
206 DOUBLE_T a68_hypot_double (DOUBLE_T, DOUBLE_T);
207 DOUBLE_T string_to_double (char *, char **);
208 DOUBLE_T inverf_double (DOUBLE_T);
209 DOUBLE_NUM_T abs_double_int (DOUBLE_NUM_T);
210 DOUBLE_NUM_T bits_to_double_int (NODE_T *, char *);
211 DOUBLE_NUM_T dble_double (NODE_T *, REAL_T);
212 DOUBLE_NUM_T double_int_to_double (NODE_T *, DOUBLE_NUM_T);
213 DOUBLE_NUM_T double_strtou (NODE_T *, char *);
214 DOUBLE_NUM_T double_udiv (NODE_T *, MOID_T *, DOUBLE_NUM_T, DOUBLE_NUM_T, int);
215 DOUBLE_T a68_neginf_double (void);
216 DOUBLE_T a68_posinf_double (void);
217 void deltagammainc_double (DOUBLE_T *, DOUBLE_T *, DOUBLE_T, DOUBLE_T, DOUBLE_T, DOUBLE_T);
218
219 GPROC genie_infinity_double;
220 GPROC genie_minus_infinity_double;
221 GPROC genie_gamma_inc_g_double;
222 GPROC genie_gamma_inc_f_double;
223 GPROC genie_gamma_inc_h_double;
224 GPROC genie_gamma_inc_gf_double;
225 GPROC genie_abs_double_compl;
226 GPROC genie_abs_double_int;
227 GPROC genie_abs_double;
228 GPROC genie_acos_double_compl;
229 GPROC genie_acosdg_double;
230 GPROC genie_acosh_double_compl;
231 GPROC genie_acosh_double;
232 GPROC genie_acos_double;
233 GPROC genie_acotdg_double;
234 GPROC genie_acot_double;
235 GPROC genie_asec_double;
236 GPROC genie_asecdg_double;
237 GPROC genie_acsc_double;
238 GPROC genie_acscdg_double;
239 GPROC genie_add_double_compl;
240 GPROC genie_add_double_bits;
241 GPROC genie_add_double_int;
242 GPROC genie_add_double;
243 GPROC genie_add_double;
244 GPROC genie_and_double_bits;
245 GPROC genie_arg_double_compl;
246 GPROC genie_asin_double_compl;
247 GPROC genie_asindg_double;
248 GPROC genie_asindg_double;
249 GPROC genie_asinh_double_compl;
250 GPROC genie_asinh_double;
251 GPROC genie_asin_double;
252 GPROC genie_atan2dg_double;
253 GPROC genie_atan2_double;
254 GPROC genie_atan_double_compl;
255 GPROC genie_atandg_double;
256 GPROC genie_atanh_double_compl;
257 GPROC genie_atanh_double;
258 GPROC genie_atan_double;
259 GPROC genie_bin_double_int;
260 GPROC genie_clear_double_bits;
261 GPROC genie_conj_double_compl;
262 GPROC genie_cas_double;
263 GPROC genie_cos_double_compl;
264 GPROC genie_cosdg_double;
265 GPROC genie_cosdg_double;
266 GPROC genie_cosh_double_compl;
267 GPROC genie_cosh_double;
268 GPROC genie_cospi_double;
269 GPROC genie_cos_double;
270 GPROC genie_cotdg_double;
271 GPROC genie_cotpi_double;
272 GPROC genie_cot_double;
273 GPROC genie_sec_double;
274 GPROC genie_secdg_double;
275 GPROC genie_csc_double;
276 GPROC genie_cscdg_double;
277 GPROC genie_curt_double;
278 GPROC genie_divab_double_compl;
279 GPROC genie_divab_double;
280 GPROC genie_divab_double;
281 GPROC genie_div_double_compl;
282 GPROC genie_div_double_int;
283 GPROC genie_double_bits_pack;
284 GPROC genie_double_max_bits;
285 GPROC genie_double_max_int;
286 GPROC genie_double_max_real;
287 GPROC genie_double_min_real;
288 GPROC genie_double_small_real;
289 GPROC genie_double_zeroin;
290 GPROC genie_elem_double_bits;
291 GPROC genie_entier_double;
292 GPROC genie_eq_double_compl;
293 GPROC genie_eq_double_bits;
294 GPROC genie_eq_double_int;
295 GPROC genie_eq_double_int;
296 GPROC genie_eq_double;
297 GPROC genie_eq_double;
298 GPROC genie_eq_double;
299 GPROC genie_eq_double;
300 GPROC genie_erfc_double;
301 GPROC genie_erf_double;
302 GPROC genie_exp_double_compl;
303 GPROC genie_exp_double;
304 GPROC genie_gamma_double;
305 GPROC genie_ge_double_bits;
306 GPROC genie_ge_double_int;
307 GPROC genie_ge_double_int;
308 GPROC genie_ge_double;
309 GPROC genie_ge_double;
310 GPROC genie_ge_double;
311 GPROC genie_ge_double;
312 GPROC genie_gt_double_bits;
313 GPROC genie_gt_double_int;
314 GPROC genie_gt_double_int;
315 GPROC genie_gt_double;
316 GPROC genie_gt_double;
317 GPROC genie_gt_double;
318 GPROC genie_gt_double;
319 GPROC genie_i_double_compl;
320 GPROC genie_i_int_double_compl;
321 GPROC genie_im_double_compl;
322 GPROC genie_inverfc_double;
323 GPROC genie_inverf_double;
324 GPROC genie_le_double_bits;
325 GPROC genie_le_double_int;
326 GPROC genie_le_double_int;
327 GPROC genie_lengthen_bits_to_double_bits;
328 GPROC genie_lengthen_double_compl_to_long_mp_complex;
329 GPROC genie_lengthen_complex_to_double_compl;
330 GPROC genie_lengthen_double_int_to_mp;
331 GPROC genie_lengthen_int_to_double_int;
332 GPROC genie_lengthen_double_to_mp;
333 GPROC genie_lengthen_real_to_double;
334 GPROC genie_le_double;
335 GPROC genie_le_double;
336 GPROC genie_le_double;
337 GPROC genie_le_double;
338 GPROC genie_ln_double_compl;
339 GPROC genie_lngamma_double;
340 GPROC genie_ln_double;
341 GPROC genie_log_double;
342 GPROC genie_lt_double_bits;
343 GPROC genie_lt_double_int;
344 GPROC genie_lt_double_int;
345 GPROC genie_lt_double;
346 GPROC genie_lt_double;
347 GPROC genie_lt_double;
348 GPROC genie_lt_double;
349 GPROC genie_minusab_double_compl;
350 GPROC genie_minusab_double_int;
351 GPROC genie_minusab_double_int;
352 GPROC genie_minusab_double;
353 GPROC genie_minusab_double;
354 GPROC genie_minus_double_compl;
355 GPROC genie_minus_double_int;
356 GPROC genie_minus_double;
357 GPROC genie_modab_double_int;
358 GPROC genie_modab_double_int;
359 GPROC genie_mod_double_bits;
360 GPROC genie_mod_double_int;
361 GPROC genie_mul_double_compl;
362 GPROC genie_mul_double_int;
363 GPROC genie_mul_double;
364 GPROC genie_mul_double;
365 GPROC genie_ne_double_compl;
366 GPROC genie_ne_double_bits;
367 GPROC genie_ne_double_int;
368 GPROC genie_ne_double_int;
369 GPROC genie_ne_double_int;
370 GPROC genie_ne_double_int;
371 GPROC genie_ne_double;
372 GPROC genie_ne_double;
373 GPROC genie_ne_double;
374 GPROC genie_ne_double;
375 GPROC genie_ne_double;
376 GPROC genie_ne_double;
377 GPROC genie_ne_double;
378 GPROC genie_ne_double;
379 GPROC genie_next_random_double;
380 GPROC genie_not_double_bits;
381 GPROC genie_odd_double_int;
382 GPROC genie_or_double_bits;
383 GPROC genie_overab_double_int;
384 GPROC genie_overab_double_int;
385 GPROC genie_over_double_bits;
386 GPROC genie_over_double_int;
387 GPROC genie_over_double;
388 GPROC genie_over_double;
389 GPROC genie_pi_double;
390 GPROC genie_plusab_double_compl;
391 GPROC genie_plusab_double_int;
392 GPROC genie_plusab_double_int;
393 GPROC genie_plusab_double;
394 GPROC genie_pow_double_compl_int;
395 GPROC genie_pow_double_int_int;
396 GPROC genie_pow_double;
397 GPROC genie_pow_double_int;
398 GPROC genie_re_double_compl;
399 GPROC genie_rol_double_bits;
400 GPROC genie_ror_double_bits;
401 GPROC genie_round_double;
402 GPROC genie_set_double_bits;
403 GPROC genie_shl_double_bits;
404 GPROC genie_shorten_double_compl_to_complex;
405 GPROC genie_shorten_double_bits_to_bits;
406 GPROC genie_shorten_long_int_to_int;
407 GPROC genie_shorten_long_mp_complex_to_double_compl;
408 GPROC genie_shorten_mp_to_double_int;
409 GPROC genie_shorten_mp_to_double;
410 GPROC genie_shorten_double_to_real;
411 GPROC genie_shr_double_bits;
412 GPROC genie_sign_double_int;
413 GPROC genie_sign_double;
414 GPROC genie_sin_double_compl;
415 GPROC genie_sindg_double;
416 GPROC genie_sinh_double_compl;
417 GPROC genie_sinh_double;
418 GPROC genie_sinpi_double;
419 GPROC genie_sin_double;
420 GPROC genie_sqrt_double_compl;
421 GPROC genie_sqrt_double;
422 GPROC genie_sqrt_double;
423 GPROC genie_sqrt_double;
424 GPROC genie_sub_double_compl;
425 GPROC genie_sub_double_bits;
426 GPROC genie_sub_double_int;
427 GPROC genie_sub_double;
428 GPROC genie_sub_double;
429 GPROC genie_tan_double_compl;
430 GPROC genie_tandg_double;
431 GPROC genie_tanh_double_compl;
432 GPROC genie_tanh_double;
433 GPROC genie_tanpi_double;
434 GPROC genie_tan_double;
435 GPROC genie_timesab_double_compl;
436 GPROC genie_timesab_double_int;
437 GPROC genie_timesab_double_int;
438 GPROC genie_timesab_double;
439 GPROC genie_timesab_double;
440 GPROC genie_times_double_bits;
441 GPROC genie_widen_double_int_to_double;
442 GPROC genie_xor_double_bits;
443 GPROC genie_beta_inc_cf_double;
444 GPROC genie_beta_double;
445 GPROC genie_ln_beta_double;
446 GPROC genie_gamma_inc_double;
447 GPROC genie_zero_double_int;
448
449 #endif
450
451 #endif
