1 /* Native functions for floating point operations. 2 3 Copyright (C) 2016, 2017, 2018 Paul Boddie <paul@boddie.org.uk> 4 5 This program is free software; you can redistribute it and/or modify it under 6 the terms of the GNU General Public License as published by the Free Software 7 Foundation; either version 3 of the License, or (at your option) any later 8 version. 9 10 This program is distributed in the hope that it will be useful, but WITHOUT 11 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 12 FOR A PARTICULAR PURPOSE. See the GNU General Public License for more 13 details. 14 15 You should have received a copy of the GNU General Public License along with 16 this program. If not, see <http://www.gnu.org/licenses/>. 17 */ 18 19 #include <fenv.h> /* feclearexcept, fetestexcept */ 20 #include <math.h> /* pow */ 21 #include <stdio.h> /* snprintf */ 22 #include <errno.h> /* errno */ 23 #include "native/common.h" 24 #include "types.h" 25 #include "exceptions.h" 26 #include "ops.h" 27 #include "progconsts.h" 28 #include "progops.h" 29 #include "progtypes.h" 30 #include "main.h" 31 32 /* Conversion from a pair of consecutive attributes to a double-precision 33 floating point number. */ 34 35 static double __TOFLOAT(__attr attr) 36 { 37 return __get_trailing_data(attr, __builtins___float_float); 38 } 39 40 /* Numeric formatting using snprintf. 41 NOTE: This might be moved elsewhere and used by other types. */ 42 43 static __attr format_number(double n, int size) 44 { 45 char *s = (char *) __ALLOCATE(size, sizeof(char)); 46 int digits; 47 48 /* Allocation should raise a memory error if it fails, so this loop should 49 terminate via the return statement or an allocation failure. */ 50 51 while (1) 52 { 53 digits = snprintf(s, size, "%f", n); 54 55 if (digits < size) 56 { 57 s = (char *) __REALLOCATE(s, (digits + 1) * sizeof(char)); 58 return __new_str(s, digits); 59 } 60 61 size = digits + 1; 62 s = (char *) __REALLOCATE(s, size * sizeof(char)); 63 } 64 65 return __NULL; 66 } 67 68 /* Floating point exception handling. */ 69 70 static void init_env(fenv_t *envp, int excepts) 71 { 72 fegetenv(envp); 73 feclearexcept(excepts); 74 } 75 76 static int test_env(fenv_t *envp, int excepts) 77 { 78 if (fetestexcept(excepts)) 79 { 80 fesetenv(envp); 81 return 1; 82 } 83 return 0; 84 } 85 86 static int have_result(fenv_t *envp, int excepts) 87 { 88 return !fetestexcept(excepts); 89 } 90 91 static __attr make_result(fenv_t *envp, double result) 92 { 93 fesetenv(envp); 94 return __new_float(result); 95 } 96 97 /* Floating point operations. */ 98 99 __attr __fn_native_float_float_add(__attr __self, __attr self, __attr other) 100 { 101 /* self and other interpreted as float */ 102 double i = __TOFLOAT(self); 103 double j = __TOFLOAT(other); 104 double result; 105 106 /* Preserve environment, clear exception state. */ 107 fenv_t env; 108 init_env(&env, FE_OVERFLOW); 109 110 result = i + j; 111 112 /* Test for result, restore state, return the new float. */ 113 if (have_result(&env, FE_OVERFLOW)) 114 return make_result(&env, result); 115 116 /* Restore state, raise exception. */ 117 if (test_env(&env, FE_OVERFLOW)) 118 __raise_overflow_error(); 119 return __NULL; 120 } 121 122 __attr __fn_native_float_float_sub(__attr __self, __attr self, __attr other) 123 { 124 /* self and other interpreted as float */ 125 double i = __TOFLOAT(self); 126 double j = __TOFLOAT(other); 127 double result; 128 129 /* Preserve environment, clear exception state. */ 130 fenv_t env; 131 init_env(&env, FE_OVERFLOW); 132 133 result = i - j; 134 135 /* Test for result, restore state, return the new float. */ 136 if (have_result(&env, FE_OVERFLOW)) 137 return make_result(&env, result); 138 139 /* Restore state, raise exception. */ 140 if (test_env(&env, FE_OVERFLOW)) 141 __raise_overflow_error(); 142 return __NULL; 143 } 144 145 __attr __fn_native_float_float_mul(__attr __self, __attr self, __attr other) 146 { 147 /* self and other interpreted as float */ 148 double i = __TOFLOAT(self); 149 double j = __TOFLOAT(other); 150 double result; 151 152 /* Preserve environment, clear exception state. */ 153 fenv_t env; 154 init_env(&env, FE_OVERFLOW | FE_UNDERFLOW); 155 156 result = i * j; 157 158 /* Test for result, restore state, return the new float. */ 159 if (have_result(&env, FE_OVERFLOW | FE_UNDERFLOW)) 160 return make_result(&env, result); 161 162 /* Restore state, raise exception. */ 163 if (test_env(&env, FE_OVERFLOW)) 164 __raise_overflow_error(); 165 if (test_env(&env, FE_UNDERFLOW)) 166 __raise_underflow_error(); 167 return __NULL; 168 } 169 170 __attr __fn_native_float_float_div(__attr __self, __attr self, __attr other) 171 { 172 /* self and other interpreted as float */ 173 double i = __TOFLOAT(self); 174 double j = __TOFLOAT(other); 175 double result; 176 177 /* Preserve environment, clear exception state. */ 178 fenv_t env; 179 init_env(&env, FE_OVERFLOW | FE_UNDERFLOW | FE_DIVBYZERO); 180 181 result = i / j; 182 183 /* Test for result, restore state, return the new float. */ 184 if (have_result(&env, FE_OVERFLOW | FE_UNDERFLOW | FE_DIVBYZERO)) 185 return make_result(&env, result); 186 187 /* Restore state, raise exception. */ 188 if (test_env(&env, FE_OVERFLOW)) 189 __raise_overflow_error(); 190 if (test_env(&env, FE_UNDERFLOW)) 191 __raise_underflow_error(); 192 if (test_env(&env, FE_DIVBYZERO)) 193 __raise_zero_division_error(); 194 return __NULL; 195 } 196 197 __attr __fn_native_float_float_mod(__attr __self, __attr self, __attr other) 198 { 199 /* self and other interpreted as float */ 200 double i = __TOFLOAT(self); 201 double j = __TOFLOAT(other); 202 double result; 203 204 /* Preserve environment, clear exception state. */ 205 fenv_t env; 206 init_env(&env, FE_OVERFLOW | FE_DIVBYZERO); 207 208 result = fmod(i, j); 209 210 /* Test for result, restore state, return the new float. */ 211 if (have_result(&env, FE_OVERFLOW | FE_DIVBYZERO)) 212 return make_result(&env, result); 213 214 /* Restore state, raise exception. */ 215 if (test_env(&env, FE_OVERFLOW)) 216 __raise_overflow_error(); 217 if (test_env(&env, FE_DIVBYZERO)) 218 __raise_zero_division_error(); 219 return __NULL; 220 } 221 222 __attr __fn_native_float_float_neg(__attr __self, __attr self) 223 { 224 /* self interpreted as float */ 225 double i = __TOFLOAT(self); 226 double result; 227 228 /* Preserve environment, clear exception state. */ 229 fenv_t env; 230 init_env(&env, FE_OVERFLOW); 231 232 result = -i; 233 234 /* Test for result, restore state, return the new float. */ 235 if (have_result(&env, FE_OVERFLOW)) 236 return make_result(&env, result); 237 238 /* Restore state, raise exception. */ 239 if (test_env(&env, FE_OVERFLOW)) 240 __raise_overflow_error(); 241 return __NULL; 242 } 243 244 __attr __fn_native_float_float_pow(__attr __self, __attr self, __attr other) 245 { 246 /* self and other interpreted as float */ 247 double i = __TOFLOAT(self); 248 double j = __TOFLOAT(other); 249 double result; 250 251 errno = 0; 252 result = pow(i, j); 253 254 /* Test for overflow. */ 255 256 if (errno == ERANGE) 257 __raise_overflow_error(); 258 259 /* Return the result. */ 260 return __new_float(result); 261 } 262 263 __attr __fn_native_float_float_le(__attr __self, __attr self, __attr other) 264 { 265 /* self and other interpreted as float */ 266 double i = __TOFLOAT(self); 267 double j = __TOFLOAT(other); 268 269 /* Return a boolean result. */ 270 return i <= j ? __builtins___boolean_True : __builtins___boolean_False; 271 } 272 273 __attr __fn_native_float_float_lt(__attr __self, __attr self, __attr other) 274 { 275 /* self and other interpreted as float */ 276 double i = __TOFLOAT(self); 277 double j = __TOFLOAT(other); 278 279 /* Return a boolean result. */ 280 return i < j ? __builtins___boolean_True : __builtins___boolean_False; 281 } 282 283 __attr __fn_native_float_float_ge(__attr __self, __attr self, __attr other) 284 { 285 /* self and other interpreted as float */ 286 double i = __TOFLOAT(self); 287 double j = __TOFLOAT(other); 288 289 /* Return a boolean result. */ 290 return i >= j ? __builtins___boolean_True : __builtins___boolean_False; 291 } 292 293 __attr __fn_native_float_float_gt(__attr __self, __attr self, __attr other) 294 { 295 /* self and other interpreted as float */ 296 double i = __TOFLOAT(self); 297 double j = __TOFLOAT(other); 298 299 /* Return a boolean result. */ 300 return i > j ? __builtins___boolean_True : __builtins___boolean_False; 301 } 302 303 __attr __fn_native_float_float_eq(__attr __self, __attr self, __attr other) 304 { 305 /* self and other interpreted as float */ 306 double i = __TOFLOAT(self); 307 double j = __TOFLOAT(other); 308 309 /* Return a boolean result. */ 310 return i == j ? __builtins___boolean_True : __builtins___boolean_False; 311 } 312 313 __attr __fn_native_float_float_ne(__attr __self, __attr self, __attr other) 314 { 315 /* self and other interpreted as float */ 316 double i = __TOFLOAT(self); 317 double j = __TOFLOAT(other); 318 319 /* Return a boolean result. */ 320 return i != j ? __builtins___boolean_True : __builtins___boolean_False; 321 } 322 323 __attr __fn_native_float_float_str(__attr __self, __attr self) 324 { 325 /* self interpreted as float */ 326 double i = __TOFLOAT(self); 327 328 /* Return a new string. */ 329 return format_number(i, 64); 330 } 331 332 __attr __fn_native_float_float_int(__attr __self, __attr self) 333 { 334 /* self interpreted as float */ 335 double i = __TOFLOAT(self); 336 337 /* NOTE: Test for conversion failure. */ 338 return __new_int((int) i); 339 } 340 341 /* Module initialisation. */ 342 343 void __main_native_float() 344 { 345 }