genie-math.c
1 //! @file genie-math.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-2026 J. Marcel van der Veer [algol68g@algol68genie.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 //! Math interpreter routines.
25
26 #include "a68g.h"
27 #include "a68g-double.h"
28 #include "a68g-genie.h"
29 #include "a68g-mp.h"
30 #include "a68g-prelude.h"
31
32
33 //! @brief Whether value is finite
34
35 void genie_is_finite_real (NODE_T * p)
36 {
37 A68G_REAL z;
38 POP_OBJECT (p, &z, A68G_REAL);
39 BOOL_T w = a68g_finite_real (VALUE (&z));
40 PUSH_VALUE (p, w, A68G_BOOL);
41 }
42
43
44 //! @brief Whether value is finite
45
46 void genie_is_finite_mp (NODE_T * p)
47 {
48 MOID_T *m = LHS_MODE (SUB (p));
49 int size = SIZE (m);
50 MP_T *z = (MP_T *) STACK_OFFSET (-size);
51 A68G_SP -= size;
52 CHECK_INIT (p, (UNSIGNED_T) MP_STATUS (z) & INIT_MASK, m);
53 BOOL_T w = A68G_FINITE_MP (z);
54 PUSH_VALUE (p, w, A68G_BOOL);
55 }
56
57
58 //! @brief Whether value is infinite
59
60 void genie_is_infinite_real (NODE_T * p)
61 {
62 A68G_REAL z;
63 POP_OBJECT (p, &z, A68G_REAL);
64 DOUBLE_T v = VALUE (&z);
65 BOOL_T w = (v == a68g_minus_inf_real ()) || (v == a68g_plus_inf_real ());
66 PUSH_VALUE (p, w, A68G_BOOL);
67 }
68
69
70 //! @brief Whether value is finite
71
72 void genie_is_infinite_mp (NODE_T * p)
73 {
74 MOID_T *m = LHS_MODE (SUB (p));
75 int size = SIZE (m);
76 MP_T *z = (MP_T *) STACK_OFFSET (-size);
77 A68G_SP -= size;
78 CHECK_INIT (p, (UNSIGNED_T) MP_STATUS (z) & INIT_MASK, m);
79 BOOL_T w = A68G_INF_MP (z);
80 PUSH_VALUE (p, w, A68G_BOOL);
81 }
82
83
84 //! @brief Whether value is +inf
85
86 void genie_is_plus_inf_real (NODE_T * p)
87 {
88 A68G_REAL z;
89 POP_OBJECT (p, &z, A68G_REAL);
90 BOOL_T w = VALUE (&z) == a68g_plus_inf_real ();
91 PUSH_VALUE (p, w, A68G_BOOL);
92 }
93
94
95 //! @brief Whether value is +inf
96
97 void genie_is_plus_inf_mp (NODE_T * p)
98 {
99 MOID_T *m = LHS_MODE (SUB (p));
100 int size = SIZE (m);
101 MP_T *z = (MP_T *) STACK_OFFSET (-size);
102 A68G_SP -= size;
103 CHECK_INIT (p, (UNSIGNED_T) MP_STATUS (z) & INIT_MASK, m);
104 BOOL_T w = (A68G_PLUS_INF_MP (z) ? A68G_TRUE : A68G_FALSE);
105 PUSH_VALUE (p, w, A68G_BOOL);
106 }
107
108
109 //! @brief Whether value is -inf
110
111 void genie_is_minus_inf_real (NODE_T * p)
112 {
113 A68G_REAL z;
114 POP_OBJECT (p, &z, A68G_REAL);
115 BOOL_T w = VALUE (&z) == a68g_minus_inf_real ();
116 PUSH_VALUE (p, w, A68G_BOOL);
117 }
118
119
120 //! @brief Whether value is -inf
121
122 void genie_is_minus_inf_mp (NODE_T * p)
123 {
124 MOID_T *m = LHS_MODE (SUB (p));
125 int size = SIZE (m);
126 MP_T *z = (MP_T *) STACK_OFFSET (-size);
127 A68G_SP -= size;
128 CHECK_INIT (p, (UNSIGNED_T) MP_STATUS (z) & INIT_MASK, m);
129 BOOL_T w = (A68G_MINUS_INF_MP (z) ? A68G_TRUE : A68G_FALSE);
130 PUSH_VALUE (p, w, A68G_BOOL);
131 }
132
133
134 //! @brief Whether value is NaN
135
136 void genie_is_nan_real (NODE_T * p)
137 {
138 A68G_REAL z;
139 POP_OBJECT (p, &z, A68G_REAL);
140 BOOL_T w = a68g_isnan_real (VALUE (&z));
141 PUSH_VALUE (p, w, A68G_BOOL);
142 }
143
144
145 //! @brief Whether value is NaN
146
147 void genie_is_nan_mp (NODE_T * p)
148 {
149 MOID_T *m = LHS_MODE (SUB (p));
150 int size = SIZE (m);
151 MP_T *z = (MP_T *) STACK_OFFSET (-size);
152 A68G_SP -= size;
153 CHECK_INIT (p, (UNSIGNED_T) MP_STATUS (z) & INIT_MASK, m);
154 BOOL_T w = (A68G_NAN_MP (z) ? A68G_TRUE : A68G_FALSE);
155 PUSH_VALUE (p, w, A68G_BOOL);
156 }
157
158 #if (A68G_LEVEL >= 3)
159
160
161 //! @brief Whether value is finite
162
163 void genie_is_finite_double (NODE_T * p)
164 {
165 A68G_LONG_REAL z;
166 POP_OBJECT (p, &z, A68G_LONG_REAL);
167 BOOL_T w = a68g_finite_double ((VALUE (&z)).f);
168 PUSH_VALUE (p, w, A68G_BOOL);
169 }
170
171
172 //! @brief Whether value is infinite
173
174 void genie_is_infinite_double (NODE_T * p)
175 {
176 A68G_LONG_REAL z;
177 POP_OBJECT (p, &z, A68G_LONG_REAL);
178 DOUBLE_T v = (VALUE (&z)).f;
179 BOOL_T w = (v == a68g_minus_inf_double ()) || (v == a68g_plus_inf_double ());
180 PUSH_VALUE (p, w, A68G_BOOL);
181 }
182
183
184 //! @brief Whether value is +inf
185
186 void genie_is_plus_inf_double (NODE_T * p)
187 {
188 A68G_LONG_REAL z;
189 POP_OBJECT (p, &z, A68G_LONG_REAL);
190 BOOL_T w = (VALUE (&z)).f == a68g_plus_inf_double ();
191 PUSH_VALUE (p, w, A68G_BOOL);
192 }
193
194
195 //! @brief Whether value is -inf
196
197 void genie_is_minus_inf_double (NODE_T * p)
198 {
199 A68G_LONG_REAL z;
200 POP_OBJECT (p, &z, A68G_LONG_REAL);
201 BOOL_T w = (VALUE (&z)).f == a68g_minus_inf_double ();
202 PUSH_VALUE (p, w, A68G_BOOL);
203 }
204
205
206 //! @brief Whether value is NaN
207
208 void genie_is_nan_double (NODE_T * p)
209 {
210 A68G_LONG_REAL z;
211 POP_OBJECT (p, &z, A68G_LONG_REAL);
212 BOOL_T w = a68g_isnan_double ((VALUE (&z)).f);
213 PUSH_VALUE (p, w, A68G_BOOL);
214 }
215
216 #endif
© J.M. van der Veer • jmvdveer@algol68genie.nl
