Lichen

templates/native/float.c

871:ce0e10d3ad2f
2019-01-25 Paul Boddie Fixed description of conversion function. trailing-data
     1 /* Native functions for floating point operations.     2      3 Copyright (C) 2016, 2017, 2018, 2019 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 of trailing data to a double-precision floating point number. */    33     34 static double __TOFLOAT(__attr attr)    35 {    36     return __get_trailing_data(attr, __builtins___float_float);    37 }    38     39 /* Numeric formatting using snprintf.    40    NOTE: This might be moved elsewhere and used by other types. */    41     42 static __attr format_number(double n, int size)    43 {    44     char *s = (char *) __ALLOCATE(size, sizeof(char));    45     int digits;    46     47     /* Allocation should raise a memory error if it fails, so this loop should    48        terminate via the return statement or an allocation failure. */    49     50     while (1)    51     {    52         digits = snprintf(s, size, "%f", n);    53     54         if (digits < size)    55         {    56             s = (char *) __REALLOCATE(s, (digits + 1) * sizeof(char));    57             return __new_str(s, digits);    58         }    59     60         size = digits + 1;    61         s = (char *) __REALLOCATE(s, size * sizeof(char));    62     }    63     64     return __NULL;    65 }    66     67 /* Floating point exception handling. */    68     69 static void init_env(fenv_t *envp, int excepts)    70 {    71     fegetenv(envp);    72     feclearexcept(excepts);    73 }    74     75 static int test_env(fenv_t *envp, int excepts)    76 {    77     if (fetestexcept(excepts))    78     {    79         fesetenv(envp);    80         return 1;    81     }    82     return 0;    83 }    84     85 static int have_result(fenv_t *envp, int excepts)    86 {    87     return !fetestexcept(excepts);    88 }    89     90 static __attr make_result(fenv_t *envp, double result)    91 {    92     fesetenv(envp);    93     return __new_float(result);    94 }    95     96 /* Floating point operations. */    97     98 __attr __fn_native_float_float_add(__attr __self, __attr self, __attr other)    99 {   100     /* self and other interpreted as float */   101     double i = __TOFLOAT(self);   102     double j = __TOFLOAT(other);   103     double result;   104    105     /* Preserve environment, clear exception state. */   106     fenv_t env;   107     init_env(&env, FE_OVERFLOW);   108    109     result = i + j;   110    111     /* Test for result, restore state, return the new float. */   112     if (have_result(&env, FE_OVERFLOW))   113         return make_result(&env, result);   114    115     /* Restore state, raise exception. */   116     if (test_env(&env, FE_OVERFLOW))   117         __raise_overflow_error();   118     return __NULL;   119 }   120    121 __attr __fn_native_float_float_sub(__attr __self, __attr self, __attr other)   122 {   123     /* self and other interpreted as float */   124     double i = __TOFLOAT(self);   125     double j = __TOFLOAT(other);   126     double result;   127    128     /* Preserve environment, clear exception state. */   129     fenv_t env;   130     init_env(&env, FE_OVERFLOW);   131    132     result = i - j;   133    134     /* Test for result, restore state, return the new float. */   135     if (have_result(&env, FE_OVERFLOW))   136         return make_result(&env, result);   137    138     /* Restore state, raise exception. */   139     if (test_env(&env, FE_OVERFLOW))   140         __raise_overflow_error();   141     return __NULL;   142 }   143    144 __attr __fn_native_float_float_mul(__attr __self, __attr self, __attr other)   145 {   146     /* self and other interpreted as float */   147     double i = __TOFLOAT(self);   148     double j = __TOFLOAT(other);   149     double result;   150    151     /* Preserve environment, clear exception state. */   152     fenv_t env;   153     init_env(&env, FE_OVERFLOW | FE_UNDERFLOW);   154    155     result = i * j;   156    157     /* Test for result, restore state, return the new float. */   158     if (have_result(&env, FE_OVERFLOW | FE_UNDERFLOW))   159         return make_result(&env, result);   160    161     /* Restore state, raise exception. */   162     if (test_env(&env, FE_OVERFLOW))   163         __raise_overflow_error();   164     if (test_env(&env, FE_UNDERFLOW))   165         __raise_underflow_error();   166     return __NULL;   167 }   168    169 __attr __fn_native_float_float_div(__attr __self, __attr self, __attr other)   170 {   171     /* self and other interpreted as float */   172     double i = __TOFLOAT(self);   173     double j = __TOFLOAT(other);   174     double result;   175    176     /* Preserve environment, clear exception state. */   177     fenv_t env;   178     init_env(&env, FE_OVERFLOW | FE_UNDERFLOW | FE_DIVBYZERO);   179    180     result = i / j;   181    182     /* Test for result, restore state, return the new float. */   183     if (have_result(&env, FE_OVERFLOW | FE_UNDERFLOW | FE_DIVBYZERO))   184         return make_result(&env, result);   185    186     /* Restore state, raise exception. */   187     if (test_env(&env, FE_OVERFLOW))   188         __raise_overflow_error();   189     if (test_env(&env, FE_UNDERFLOW))   190         __raise_underflow_error();   191     if (test_env(&env, FE_DIVBYZERO))   192         __raise_zero_division_error();   193     return __NULL;   194 }   195    196 __attr __fn_native_float_float_mod(__attr __self, __attr self, __attr other)   197 {   198     /* self and other interpreted as float */   199     double i = __TOFLOAT(self);   200     double j = __TOFLOAT(other);   201     double result;   202    203     /* Preserve environment, clear exception state. */   204     fenv_t env;   205     init_env(&env, FE_OVERFLOW | FE_DIVBYZERO);   206    207     result = fmod(i, j);   208    209     /* Test for result, restore state, return the new float. */   210     if (have_result(&env, FE_OVERFLOW | FE_DIVBYZERO))   211         return make_result(&env, result);   212    213     /* Restore state, raise exception. */   214     if (test_env(&env, FE_OVERFLOW))   215         __raise_overflow_error();   216     if (test_env(&env, FE_DIVBYZERO))   217         __raise_zero_division_error();   218     return __NULL;   219 }   220    221 __attr __fn_native_float_float_neg(__attr __self, __attr self)   222 {   223     /* self interpreted as float */   224     double i = __TOFLOAT(self);   225     double result;   226    227     /* Preserve environment, clear exception state. */   228     fenv_t env;   229     init_env(&env, FE_OVERFLOW);   230    231     result = -i;   232    233     /* Test for result, restore state, return the new float. */   234     if (have_result(&env, FE_OVERFLOW))   235         return make_result(&env, result);   236    237     /* Restore state, raise exception. */   238     if (test_env(&env, FE_OVERFLOW))   239         __raise_overflow_error();   240     return __NULL;   241 }   242    243 __attr __fn_native_float_float_pow(__attr __self, __attr self, __attr other)   244 {   245     /* self and other interpreted as float */   246     double i = __TOFLOAT(self);   247     double j = __TOFLOAT(other);   248     double result;   249    250     errno = 0;   251     result = pow(i, j);   252    253     /* Test for overflow. */   254    255     if (errno == ERANGE)   256         __raise_overflow_error();   257    258     /* Return the result. */   259     return __new_float(result);   260 }   261    262 __attr __fn_native_float_float_le(__attr __self, __attr self, __attr other)   263 {   264     /* self and other interpreted as float */   265     double i = __TOFLOAT(self);   266     double j = __TOFLOAT(other);   267    268     /* Return a boolean result. */   269     return i <= j ? __builtins___boolean_True : __builtins___boolean_False;   270 }   271    272 __attr __fn_native_float_float_lt(__attr __self, __attr self, __attr other)   273 {   274     /* self and other interpreted as float */   275     double i = __TOFLOAT(self);   276     double j = __TOFLOAT(other);   277    278     /* Return a boolean result. */   279     return i < j ? __builtins___boolean_True : __builtins___boolean_False;   280 }   281    282 __attr __fn_native_float_float_ge(__attr __self, __attr self, __attr other)   283 {   284     /* self and other interpreted as float */   285     double i = __TOFLOAT(self);   286     double j = __TOFLOAT(other);   287    288     /* Return a boolean result. */   289     return i >= j ? __builtins___boolean_True : __builtins___boolean_False;   290 }   291    292 __attr __fn_native_float_float_gt(__attr __self, __attr self, __attr other)   293 {   294     /* self and other interpreted as float */   295     double i = __TOFLOAT(self);   296     double j = __TOFLOAT(other);   297    298     /* Return a boolean result. */   299     return i > j ? __builtins___boolean_True : __builtins___boolean_False;   300 }   301    302 __attr __fn_native_float_float_eq(__attr __self, __attr self, __attr other)   303 {   304     /* self and other interpreted as float */   305     double i = __TOFLOAT(self);   306     double j = __TOFLOAT(other);   307    308     /* Return a boolean result. */   309     return i == j ? __builtins___boolean_True : __builtins___boolean_False;   310 }   311    312 __attr __fn_native_float_float_ne(__attr __self, __attr self, __attr other)   313 {   314     /* self and other interpreted as float */   315     double i = __TOFLOAT(self);   316     double j = __TOFLOAT(other);   317    318     /* Return a boolean result. */   319     return i != j ? __builtins___boolean_True : __builtins___boolean_False;   320 }   321    322 __attr __fn_native_float_float_str(__attr __self, __attr self)   323 {   324     /* self interpreted as float */   325     double i = __TOFLOAT(self);   326    327     /* Return a new string. */   328     return format_number(i, 64);   329 }   330    331 __attr __fn_native_float_float_int(__attr __self, __attr self)   332 {   333     /* self interpreted as float */   334     double i = __TOFLOAT(self);   335    336     /* NOTE: Test for conversion failure. */   337     return __new_int((int) i);   338 }   339    340 /* Module initialisation. */   341    342 void __main_native_float()   343 {   344 }