/** * -- IEEE Floating-Point word set (EXPERIMENTAL) * * Copyright (C) 2005, 2009, 2010, 2020 David N. Williams * * @see LGPL * @author David N. Williams @(#) %derived_by: dnw % * @version %version: 0.6.2% * (%date_modified: Tue Sep 08 09:22:00 2020 %) * * If you take advantage of the option in the LGPL to put a * particular version of this library under the GPL, the author * would regard it as polite if you would put any direct * modifications under the LGPL as well, and include a copy of * this request near the beginning of the modified library * source. A "direct modification" is one that enhances or * extends the library in line with its original concept, as * opposed to developing a distinct application or library which * might use it. * * @description * This pfe loadable module implements much of the proposed IEEE-FP * Floating-Point word set, some fpu control/status register access * words, and some bindings to C99 fp functions, including environment, * exception, and rounding-mode functions, for experimentation. * * The unproposed word FH. does IEEE 754-2008 standard reproducible * hex fp output. The proposed word >IEEEFLOAT recognizes conformant * text string input, based on sscanf. * * Several IEEE-FP words are already in pfe's FLOATING-EXT * environment, which is loaded by this module. * * This module is intended to be POSIX compliant. It is known to work * on 32-bit Mac OS X ppc/intel Leopard and GNU/Linux systems, and * 64-bit macOS Catalina and Linux Mint 19 systems. */ #define _P4_SOURCE 1 #include #include /* for BITSOF in pfe-0.33.58 */ #ifdef __linux__ #define __USE_ISOC99 1 #endif #include #include // This is needed in the alternate exception handling section. #ifdef __linux__ /* BEGIN quote http://graphviz.sourcearchive.com/documentation/2.16/gvrender__pango_8c-source.html */ /* _GNU_SOURCE is needed (supposedly) for the feenableexcept * prototype to be defined in fenv.h on GNU systems. * Presumably it will do no harm on other systems. */ #ifndef _GNU_SOURCE #define _GNU_SOURCE #endif /* We are not supposed to need __USE_GNU, but I can't see * how to get the prototype for fedisableexcept from * /usr/include/fenv.h without it. */ #ifndef __USE_GNU #define __USE_GNU #endif /* END quote */ #endif // __linux__ #include #if 0 #if __STDC_VERSION__+0 > 199900L #pragma STDC FENV_ACCESS ON /* ignored by gcc */ #pragma GCC FENV_ACCESS ON /* also ignored */ #endif #endif #include /* p4_d_negate() */ #include /* for synonyms */ #include /* P4_fatal () */ #include "ieeefp-ext.h" #define CELLBITS BITSOF (p4cell) #define DEFINED_PPC (defined(__ppc__) || defined(__ppc64__)) #define DEFINED_INTEL (defined(__i386__) || defined(__x86_64__)) /* The following is used for ppc FPSCR access and for fp * constants. For the constants it's a kludge -- couldn't get * unsigned long long int to work in the analogous union. */ #ifdef ABI_32 typedef union { struct { #if DEFINED_PPC unsigned long hi; unsigned long lo; #elif DEFINED_INTEL unsigned long lo; unsigned long hi; #else #error Can be compiled only for a ppc or intel cpu. #endif } i; double d; } hexdouble; #elif defined ABI_64 typedef union { p4cell i; double d; } hexdouble; #else #error Can be compiled only with ABI_32 or ABI_64. #endif /****************************************************************/ /* IEEE special constants */ /****************************************************************/ FCode (p4_plus_inf) { hexdouble t; #ifdef ABI_32 t.i.hi = 0x7FF00000; t.i.lo = 0; #else t.i = 0x7FF0000000000000; #endif *--FP = t.d; } FCode (p4_minus_inf) { hexdouble t; #ifdef ABI_32 t.i.hi = 0xFFF00000; t.i.lo = 0; #else t.i = 0xFFF0000000000000; #endif *--FP = t.d; } FCode (p4_plus_nan) { hexdouble t; #ifdef ABI_32 t.i.hi = 0x7FF80000; t.i.lo = 0; #else t.i = 0x7FF8000000000000; #endif *--FP = t.d; } FCode (p4_minus_nan) { hexdouble t; #ifdef ABI_32 t.i.hi = 0xFFF80000; t.i.lo = 0; #else t.i = 0xFFF8000000000000; #endif *--FP = t.d; } /****************************************************************/ /* elementary functions new in C99 */ /****************************************************************/ /** F*+ (f: x y z -- y*z+x ) */ FCode (p4_f_star_plus) { FP[2] = fma ( FP[1], FP[0], FP[2]); FP += 2; } /** FCBRT (f: x -- x^[1/3] ) */ FCode (p4_f_cbrt) { *FP = cbrt (*FP); } /** FDIM (f: x y -- x-y | +0 ) */ FCode (p4_f_dim) { FP[1] = fdim ( FP[1], FP[0]); FP++; } /** FEXP2 (f: x -- 2^x ) */ FCode (p4_f_exp2) { *FP = exp2 (*FP); } /** FLOG2 (f: x -- log.base.2[x] ) */ FCode (p4_f_log2) { *FP = log2 (*FP); } /** FERF (f: x -- erf[x] ) */ FCode (p4_f_erf) { *FP = erf (*FP); } /** FERFC (f: x -- 1-erf[x] ) */ FCode (p4_f_erfc) { *FP = erfc (*FP); } /** FGAMMA (f: x -- gamma[x] ) */ FCode (p4_f_gamma) { *FP = tgamma (*FP); } /** FLNGAMMA (f: x -- ln[gamma[x]] ) */ FCode (p4_f_ln_gamma) { *FP = lgamma (*FP); } /****************************************************************/ /* nearest integer functions */ /****************************************************************/ /** FCEIL (f: r1 -- r2 ) */ FCode (p4_fceil) { *FP = ceil (*FP); } /** FNEARBYINT (f: r1 -- r2 ) */ FCode (p4_fnearbyint) { *FP = nearbyint (*FP); } /****************************************************************/ /* floating-point auxiliary functions */ /****************************************************************/ /** FCLASSIFY (f: x -- s: type ) * Return the appropriate value FP_INFINITE, FP_NAN, FP_NORMAL, * FP_SUBNORMAL, or FP_ZERO provided by the host C99 compiler. * The corresponding Forth constants are FP-INFINITE, etc. */ FCode (p4_fclassify) { *--SP = fpclassify (*FP++); } /** FINITE? (f: x -- s: flag ) */ FCode (p4_finite_q) { *--SP = isfinite (*FP++) ? ~0 : 0 ; } /** FINFINITE? (f: x -- s: flag ) */ FCode (p4_finfinite_q) { *--SP = isinf (*FP++) ? ~0 : 0 ; } /** FNAN? (f: x -- s: flag ) */ FCode (p4_fnan_q) { *--SP = isnan (*FP++) ? ~0 : 0 ; } /** FNORMAL? (f: x -- s: flag ) */ FCode (p4_fnormal_q) { *--SP = isnormal (*FP++) ? ~0 : 0 ; } /** FSUBNORMAL? (f: x -- s: flag ) */ FCode (p4_fsubnormal_q) { *--SP = ( fpclassify (*FP++) == FP_SUBNORMAL ) ? ~0 : 0 ; } /** FCOPYSIGN (f: x y -- |x|*sgn[y] ) */ FCode (p4_fcopysign) { FP[1] = copysign ( FP[1], FP[0]); FP++ ; } /** FNEXTAFTER (f: x y -- x.next ) * Return the next machine representable number after x in the y * direction. */ FCode (p4_fnextafter) { FP[1] = nextafter ( FP[1], FP[0] ); FP++; } /** FSIGNBIT (f: x -- s: minus? ) */ FCode (p4_fsignbit) { signbit (*FP++) ? (*--SP = ~0) : (*--SP = 0); } /** FREXP (f: x -- frac s: n ) * Return the fractional part of x as a floating-point number, * frac = 0.0 or 0.5 <= frac < 1.0, and the power n such that * frac*2^n = x. */ FCode (p4_frexp) { *FP = frexp ( *FP, (int *)--SP ); } /* We learned the following algorithm from Andrew Haley's reference * implementation of NEXTUP (comp.lang.forth, 23 Jul 2009). Note that * Catalina does not have nextup(). */ #ifdef ABI_32 static double nextup (double x) { hexdouble t; p4dcell a,b; if ( isnan (x) || (!signbit (x) && isinf (x)) ) return x; x += 0.0; // convert -0 to +0 t.d = x; a.hi = t.i.hi; a.lo = t.i.lo; b.hi =0; b.lo = 1; if (a.hi < 0) p4_d_minus (&a,&b); else p4_d_plus (&a,&b); t.i.hi = a.hi; t.i.lo = a.lo; return t.d; } #else /* ABI_64 */ static double nextup (double x) { hexdouble t; if ( isnan (x) || (!signbit (x) && isinf (x)) ) return x; x += 0.0; // convert -0 to +0 t.d = x; if (t.i < 0) t.i -= 1; else t.i += 1; return t.d; } #endif /** FNEXTUP (f: r1 -- r2 ) * FNEXTDOWN (f: r1 -- r2 ) * When r1 is a nonzero real number, FNEXTUP returns the next * affinely extended real in the default format that compares * larger than r1, and FNEXTDOWN returns the next one that * compares less than r1. See IEEE 754-2008 5.3.1, "General * operations" for the behavior when r1 is an IEEE special. */ FCode (p4_fnextup) { *FP = nextup (*FP); } FCode (p4_fnextdown) { *FP = -nextup (-*FP);} /** FSCALBN (f: x s: n -- f: x*2^n ) */ FCode (p4_fscalbn) { *FP = ldexp ( *FP, *SP++ ); } /** FMODF (f: x -- frac integ ) * Return the integer part of x as a double, and the fractional * part f of x with |f| < 1, both having the same sign as x, so * that x = frac + integ. */ FCode (p4_fmodf) { double integ; *FP = modf (*FP, &integ); *--FP = integ; } /** FMODFD (f: x -- frac s: d ) * A version of MODF that returns the integer part as a * double-cell signed integer. Not in C99. * TENTATIVE! */ FCode (p4_fmodfd) { /* based on F>D in floating-ext.c */ double integ, hi, lo; int sign; *FP = modf (*FP, &integ); if (integ < 0) sign = 1, integ = -integ; else sign = 0; lo = modf (ldexp (integ, -CELLBITS), &hi); SP -= 2; SP[0] = (p4ucell) hi; SP[1] = (p4ucell) ldexp (lo, CELLBITS); if (sign) p4_d_negate ((p4dcell *) &SP[0]); } /** FLOGB (f: x -- f: b.exponent ) * Leave the exponent (radix b = FLT_RADIX) of the * floating-point representation. */ FCode (p4_flogb) { *FP = logb (*FP); } /** FILOGB (f: x -- s: b.exponent ) * Leave the exponent (radix b = FLT_RADIX) of the * floating-point representation, with special values: * x exp * 0.0 FP_ILOGB0 * Inf INT_MAX * -Inf INT_MAX * Nan FP_ILOGBNAN * The special output constants are defined elsewhere with Forth * names FP-ILOGB0, FP-ILOGBNAN, INT-MAX. */ FCode (p4_filogb) { *--SP = logb (*FP++); } /****************************************************************/ /* floating point text format */ /****************************************************************/ #if !defined HAVE_POW10 && !defined PFE_HAVE_POW10 #define pow10(X) pow(10.0,(X)) #endif /** FH. (f: x -- ) * Send x to standard output in IEEE-FP hex float format, with enough * hex digits for exact reproduction of the binary format of x. */ FCode (p4_fh_dot) { // p4_outf ("%.*a ", (int) PRECISION, *FP++); p4_outf ("%a ", *FP++); } /** >IEEEFLOAT ( c-addr u -- flag f: x ) * This word extends the functionality of >FLOAT to include IEEE special * data. */ FCode (p4_to_ieeefloat) { char buf[80]; p4_char_t* p; static const char *fmt[] = { "%lf%n %n%d%n$", "%lf%*1[DdEe]%n %n%d%n$", }; int i, n, exp, n1, n2, n3; double r; p = (p4_char_t *) SP[1]; n = p4_dash_trailing (p, *SP++); if (n == 0) { *--FP = 0; *SP = P4_TRUE; return; } p4_store_c_string (p, n, buf, sizeof buf); p4_strcat (buf, "$"); # if defined SYS_EMX /* emx' sscanf(), %lf conversion, doesn't read past 0E accepting the * "0" as good number when no exponent follows. Therefore we change * the 'E' to 'D', ugly hack but helps. */ p4_upper (buf, n); if (p4_strchr (buf, 'E')) *p4_strchr (buf, 'E') = 'D'; # endif if (1 == sscanf (buf, "%lf%n$", &r, &n1) && n == n1) { *--FP = r; *SP = P4_TRUE; return; } for (i = 0; i < DIM (fmt); i++) { switch (sscanf (buf, fmt[i], &r, &n1, &n2, &exp, &n3)) { case 1: if (n < n2) break; *--FP = r; *SP = P4_TRUE; return; case 2: if (n1 != n2 || n < n3) break; *--FP = r * pow10 (exp); *SP = P4_TRUE; return; } } *SP = P4_FALSE; } /****************************************************************/ /* floating-point environment */ /****************************************************************/ /* These words implement Forth bindings for the C99 functions * fegetenv(), fesetenv(), feholdexcept(), and feupdateenv(). In * the stack effects, "fenvp" indicates the address of an * implementation-defined, opaque structure for control mode and * exception bit data for the floating-point state, * corresponding to C99 fenv_t. For example, in Mac OS X * Leopard ppc, it is just an unsigned int that holds a copy of * the FPSCR register (floating-point status and control), but * for Leopard intel it holds copies of the x87 fpu status and * control registers, as well as the SSE status and control * register, MXCSR. GNU/Linux is similar to OS X intel, but * more opaque. */ /* Align BSD? with C99 */ #if !defined FE_DEFL_ENV && defined FE_DFL_ENV #define FE_DEFL_ENV FE_DFL_ENV #endif /** /FENV ( -- fenv_t.size ) */ /** FE-DFL-ENV ( -- default.fenvp) */ /** FEGETENV ( fenvp -- ) * Store current floating-point environment at fenvp. */ FCode (p4_fegetenv) { fegetenv ( (fenv_t*) *SP++ ); } /** FESETENV ( fenvp -- ) * Set the floating-point environment to that pointed to by * fenvp. */ FCode (p4_fesetenv) { fesetenv ( (fenv_t*) SP++ ); } /** FEHOLDEXCEPT ( -- fenvp ) * Leave the current floating-point environment pointer for * later restoration, and install an environment that turns off * floating-point exceptions. */ FCode (p4_feholdexcept) { feholdexcept ( (fenv_t*) --SP ); } /** FEUPDATEENV ( fenvp -- ) * Set the floating-point environment to that pointed to by * fenvp, and raise the exceptions that were up just before the * call. */ FCode (p4_feupdateenv) { feupdateenv ( (fenv_t*) SP++ ); } /****************************************************************/ /* floating-point exception flags */ /****************************************************************/ /* In the following stack effects, excepts stands for the * bitwise OR of a subset of the fp exception flag constants * FDIVBYZERO, FINEXACT, FINVALID, FOVERFLOW, and * FUNDERFLOW, with FALL-EXCEPT the OR of all five. * * POSIX returns for errors are assumed. */ /** GET-FFLAGS ( excepts -- flags ) * The flags output is the bitwise OR of the fp exception * constants corresponding to those flags that are both on in * the current fp state and present in excepts. */ FCode (p4_get_fflags) { *SP = fetestexcept (*SP & FE_ALL_EXCEPT); } /** SET-FFLAGS ( excepts -- ) * Turn on the fp exception status flags corresponding to the fp * exceptions present in excepts. */ FCode (p4_set_fflags) // { feraiseexcept (*SP++); } { if ( feraiseexcept (*SP++ & FE_ALL_EXCEPT) ) P4_fatal ("Cannot get raise fp flags!"); } /** CLEAR-FFLAGS ( excepts -- ) * Clear the fp exception status flags corresponding to the fp * exceptions present in excepts. */ FCode (p4_clear_fflags) //{ feclearexcept (*SP++); } { unsigned int excepts = *SP++ & FE_ALL_EXCEPT; if ( !excepts ) return ; if ( feclearexcept (excepts) ) P4_fatal ("Cannot get clear fp flags!"); } /****************************************************************/ /* floating-point rounding modes */ /****************************************************************/ /* The Forth constants FR-DOWNWARD, FR-UPWARD, FR-TONEAREST, * FR-TOWARDZERO, corresponding to C99 rounding mode values with "FE_" * instead of "FR-" in their names, are defined under P4_LISTWORDS. * They represent the legal rounding modes. * * The approach taken in the IEEE-FP proposal is likely to be different. * These words just bind the C99 functions to Forth. */ /** GET-FROUND ( -- round ) * Leave the current rounding mode value. */ FCode (p4_get_fround) { if ( (*--SP = fegetround ()) < 0 ) P4_fatal ("Cannot get fp rounding direction!"); } /** SET-FROUND ( round -- ) * Set the current rounding mode to round. */ FCode (p4_set_fround) { if ( (fesetround (*SP++)) < 0 ) P4_fatal ("Cannot set fp rounding direction!"); } /****************************************************************/ /* alternate floating-point exception handling */ /****************************************************************/ /*** GNU/Linux fp environment extensions ***/ #ifndef __linux__ #if DEFINED_PPC #define FE_EXCEPT_SHIFT 22 // shift flags right to get enabling masks #define FM_ALL_EXCEPT FE_ALL_EXCEPT >> FE_EXCEPT_SHIFT /* GNU C Library: http://www.gnu.org/software/libc/manual/html_node/Control-Functions.html - Function: int fegetexcept (int excepts) The function returns a bitmask of all currently enabled exceptions. It returns -1 in case of failure. The excepts argument appears in other functions in fenv.h, and corresponds to the FE_xxx exception flag constants. It is unclear whether the bitmask is for the flags or the masks. We return that for the flags, which corresponds to the excepts argument in feenableexcept(excepts) and fedisableexcept(excepts). In GNU/Linux the argument is void, and that's what we implement. Linux "man fegetenv" appears to suggest that it's the mask corresponding to bits in excepts that is returned. */ static int fegetexcept (void) { static fenv_t fenv; return ( fegetenv (&fenv) ? -1 : ( ( fenv & (FM_ALL_EXCEPT) ) << FE_EXCEPT_SHIFT ) ); } static int feenableexcept (unsigned int excepts) { static fenv_t fenv; unsigned int new_excepts = (excepts & FE_ALL_EXCEPT) >> FE_EXCEPT_SHIFT, old_excepts; // all previous masks // The flags are cleared so a handler doesn't kick in. if ( feclearexcept (excepts & FE_ALL_EXCEPT) || fegetenv (&fenv) ) return -1; old_excepts = (fenv & FM_ALL_EXCEPT) << FE_EXCEPT_SHIFT; fenv = (fenv & ~new_excepts) | new_excepts; return ( fesetenv (&fenv) ? -1 : old_excepts ); } static int fedisableexcept (unsigned int excepts) { static fenv_t fenv; unsigned int still_on = ~( (excepts & FE_ALL_EXCEPT) >> FE_EXCEPT_SHIFT ), old_excepts; // previous masks if ( fegetenv (&fenv) ) return -1; old_excepts = (fenv & FM_ALL_EXCEPT) << FE_EXCEPT_SHIFT; fenv &= still_on; return ( fesetenv (&fenv) ? -1 : old_excepts ); } #elif DEFINED_INTEL static int fegetexcept (void) { static fenv_t fenv; return fegetenv (&fenv) ? -1 : ( (~fenv.__control) & FE_ALL_EXCEPT ); } static int feenableexcept (unsigned int excepts) { static fenv_t fenv; unsigned int new_excepts = excepts & FE_ALL_EXCEPT, old_excepts; // previous masks // The flags are cleared so a handler doesn't kick in. if ( feclearexcept (new_excepts) | fegetenv (&fenv) ) return -1; old_excepts = fenv.__control & FE_ALL_EXCEPT; // unmask fenv.__control &= ~new_excepts; fenv.__mxcsr &= ~(new_excepts << 7); return ( fesetenv (&fenv) ? -1 : old_excepts ); } static int fedisableexcept (unsigned int excepts) { static fenv_t fenv; unsigned int new_excepts = excepts & FE_ALL_EXCEPT, old_excepts; // all previous masks if ( fegetenv (&fenv) ) return -1; old_excepts = fenv.__control & FE_ALL_EXCEPT; // mask fenv.__control |= new_excepts; fenv.__mxcsr |= new_excepts << 7; return ( fesetenv (&fenv) ? -1 : old_excepts ); } #endif // PPC or INTEL enabling #endif // not __linux__ /*** PPC FPSCR REGISTER ***/ #if DEFINED_PPC #define getfpscr(x) asm volatile ("mffs %0" : "=f" (x)); #define setfpscr(x) asm volatile ("mtfsf 255,%0" : : "f" (x)); /** FPSCR@ ( -- u ) * Leave the ppc 32-bit fp status and control register. */ FCode (p4_fpscr_fetch) { hexdouble t; getfpscr (t.d); *--SP = t.i.lo; } /** FPSCR! ( u -- ) * Store u in the ppc 32-bit fp status and control register. */ FCode (p4_fpscr_store) { hexdouble t; t.i.hi = 0; t.i.lo = *SP++; setfpscr (t.d); } /** (FENABLE) ( excepts -- ) ** (FDISABLE) ( excepts -- ) * These words are a low level ppc version of FENABLE and * FDISABLE. Turn on, respectively, off those enabling bits in * the ppc FPSCR register that are on in excepts, and leave the * rest alone. Note that excepts is an OR of FE_xxx masks. */ FCode (p4_paren_fenable) { hexdouble t; getfpscr(t.d); t.i.lo |= (*SP++ & FE_ALL_EXCEPT) >> 22; setfpscr(t.d); } FCode (p4_paren_fdisable) { hexdouble t; getfpscr(t.d); t.i.lo &= ~( (*SP++ & FE_ALL_EXCEPT) >> 22 ); setfpscr(t.d); } #endif // DEFINED_PPC /*** INTEL X87CR, X87SR, MXCSR REGISTER ACCESS ***/ #if DEFINED_INTEL // x87 fpu #define getx87cr(x) asm ("fnstcw %0" : "=m" (x)); #define setx87cr(x) asm ("fldcw %0" : "=m" (x)); #define getx87sr(x) asm ("fnstsw %0" : "=m" (x)); // SIMD, gcc with Intel Core 2 Duo uses SSE2(4) #define getmxcsr(x) asm ("stmxcsr %0" : "=m" (x)); #define setmxcsr(x) asm ("ldmxcsr %0" : "=m" (x)); FCode (p4_x87cr_fetch) { unsigned short cr; getx87cr (cr); *--SP = cr; } FCode (p4_x87cr_store) { unsigned short cr = *SP++; setx87cr (cr); } FCode (p4_x87sr_fetch) { unsigned short x87sr; getx87sr (x87sr); *--SP = x87sr; } FCode (p4_mxcsr_fetch) { unsigned int csr; getmxcsr (csr); *--SP = csr; } FCode (p4_mxcsr_store) { setmxcsr ((p4ucell) *SP++); } /** (FENABLE) ( excepts -- ) ** (FDISABLE) ( excepts -- ) * These words are a low level intel version of FENABLE and * FDISABLE. Turn on, respectively, off those enabling bits in * the intel fpu registers that are on in excepts, and leave the * rest alone. Note that excepts is an OR of FE_xxx masks. */ FCode (p4_paren_fenable) { unsigned int mxmb = (*SP++ & FE_ALL_EXCEPT) << 7, csr; unsigned short x87mb = mxmb >> 7, cr; getx87cr (cr); cr &= ~x87mb; //unmask with x87mb setx87cr (cr); getmxcsr (csr); csr &= ~mxmb; //unmask with mxmb setmxcsr (csr); } FCode (p4_paren_fdisable) { unsigned int mxmb = (*SP++ & FE_ALL_EXCEPT) << 7, csr; unsigned short x87mb = mxmb >> 7, cr; getx87cr (cr); cr |= x87mb; //mask with x87mb setx87cr (cr); getmxcsr (csr); csr |= mxmb; //mask with mxmb setmxcsr (csr); } #endif // DEFINED_INTEL /* In the following, excepts is the bitwise OR of a subset of * values of the exception flag constants corresponding to fp * exceptions that currently have alternate handling enabled, or * are to have it enabled or disabled. * * In some implementations of gclib for some cpu's, the * exception flag constants actually use the same bits as those * of the status flags in a floating-point status register, and * are shifted by a fixed amount from the bits that enable or * mask alternate handling, possibly in the same register. * * The point is that the exception flag constants serve a dual * purpose, logically representing both exception status flag * bits and exception enabing or masking bits. */ // This shouldn't be necessary! It comes right out of fenv.h. #ifdef __linux__ extern int fegetexcept (void); extern int feenableexcept (int __excepts); extern int fedisableexcept (int __excepts); #endif /** FENABLED ( -- excepts ) * Leave the excepts corresponds to the fp exceptions currently * enabled for alternate handling. */ FCode (p4_fenabled) { if ( (*--SP = fegetexcept()) == -1 ) P4_fatal ("Can't get enabled exceptions!"); } /** FEENABLEEXCEPT ( excepts -- excepts.old ) * Enable the exceptions in excepts for alternate handling, and * leave the previously enabled exceptions as excepts.old */ FCode (p4_feenableexcept) { if ( (*SP = feenableexcept(*SP)) == -1 ) P4_fatal ("Can't enable exceptions!"); } /** FENABLE ( excepts -- ) * Enable the fp exceptions in excepts for alternate handling, * after first clearing all fp exception status flags. */ FCode (p4_fenable) { if ( feclearexcept (FE_ALL_EXCEPT) ) P4_fatal ("Can't clear exception flags!"); if ( feenableexcept(*SP++) == -1 ) P4_fatal ("Can't enable exceptions!"); } /** FEDISABLEEXCEPT ( excepts -- excepts.old ) * Disable the exceptions in excepts for alternate handling, and * leave the previously enabled exceptions as excepts.old. */ FCode (p4_fedisableexcept) { if ( feclearexcept (FE_ALL_EXCEPT) ) P4_fatal ("Can't clear exception flags!"); if ( (*SP = fedisableexcept(*SP)) == -1 ) P4_fatal ("Can't disable exceptions!"); } /** FDISABLE ( excepts -- ) * Disable the fp exceptions in excepts for alternate handling, * after first clearing all fp exception status flags. */ FCode (p4_fdisable) { if ( fedisableexcept(*SP++) == -1 ) P4_fatal ("Can't disable exceptions!"); } #include static p4xt current_fhdl = 0; /** SET-FHANDLER ( xt -- ) * Set the fp exception handler to use xt when enabled. If * alternate handling is enabled and an fp exception occurs, xt * will be executed with the appropriate ANS Forth fp throw code * topmost on the data stack, possibly followed by other * implementation-defined data. An ambiguous condition exists * if execution does not end by peforming THROW on the throw * code. The default is the xt of THROW, which is initialized * by INSTALL-FHANDLING. */ FCode (p4_set_fhandler) { current_fhdl = (p4xt) *SP++; } /** GET-FHANDLER ( -- xt ) * Return the current xt, which will be used if alternate fp * exception handling is enabled. */ FCode (p4_get_fhandler) { *--SP = (p4ucell) current_fhdl; } #include #ifndef _XOPEN_SOURCE #define _XOPEN_SOURCE 1 #endif #include static void fhdl ( int sig, siginfo_t *sip, ucontext_t *scp ) { int fe_code = sip->si_code; switch (fe_code) { case FPE_FLTDIV: fe_code = -42; break; // divideByZero case FPE_FLTINV: fe_code = -46; break; // invalid case FPE_FLTOVF: fe_code = -43; break; // overflow case FPE_FLTUND: fe_code = -54; break; // underflow case FPE_FLTRES: fe_code = -41; break; // inexact #if DEFINED_INTEL && !defined __linux__ case FPE_NOOP: fe_code = -55; break; // denormal (experimental) #endif default: // should not occur { printf ("\nSignal is: %i\n", sig); printf ("SIGFPE code: %i\n", fe_code); fe_code = -55; // unidentified fp fault } } // This test should not be necessary, but who knows. if ( !current_fhdl ) p4_throw(fe_code); *--SP = fe_code; # ifndef PFE_CALL_THREADING PFE.execute (current_fhdl); # else p4_call (current_fhdl); # endif } /** INSTALL-FHANDLING ( -- ) * Establish the alternate fp exception handler, and initialize * the xt it executes to that of THROW. Thereafter the handler * will fire on a floating-point exception, if alternate fp * handling is enabled. This word is executed when the ieeefp * extensions word set is loaded. It may also be executed by an * application, which may be necessary on some systems after an * ABORT, to reestablish the handler. */ FCode (p4_install_fhandling) { struct sigaction act; act.sa_sigaction = (void(*))fhdl; sigemptyset (&act.sa_mask); // no blocked signals act.sa_flags = SA_SIGINFO; // pass siginfo to handler // Do this first in case the handler fires: current_fhdl = p4_name_from ( p4_find ((p4_char_t *) "THROW", 5) ); if (sigaction (SIGFPE, &act, (struct sigaction *)0) != 0) P4_fatal ("Can't install fp signal handler!"); } P4_LISTWORDS (ieeefp) = { P4_NEED ("floating-ext"), P4_INTO ("EXTENSIONS", 0), /* IEEE special constants */ P4_FXco ("+INF", p4_plus_inf), P4_FXco ("-INF", p4_minus_inf), P4_FXco ("+NAN", p4_plus_nan), P4_FXco ("-NAN", p4_minus_nan), /* elementary functions new in C99 */ P4_FXco ("F*+", p4_f_star_plus), P4_FXco ("FCBRT", p4_f_cbrt), P4_FXco ("FDIM", p4_f_dim), P4_FXco ("FEXP2", p4_f_exp2), P4_FXco ("FLOG2", p4_f_log2), P4_FXco ("FERF", p4_f_erf), P4_FXco ("FERFC", p4_f_erfc), P4_FXco ("FLNGAMMA", p4_f_ln_gamma), P4_FXco ("FGAMMA", p4_f_gamma), /* nearest integer functions */ P4_FXco ("FCEIL", p4_fceil), P4_FXco ("FNEARBYINT", p4_fnearbyint), /* floating-point auxiliary functions */ P4_FXco ("FCLASSIFY", p4_fclassify), P4_OCoN ("FP-INFINITE", FP_INFINITE), P4_OCoN ("FP-NAN", FP_NAN), P4_OCoN ("FP-NORMAL", FP_NORMAL), P4_OCoN ("FP-SUBNORMAL", FP_SUBNORMAL), P4_OCoN ("FP-ZERO", FP_ZERO), P4_FXco ("FINITE?", p4_finite_q), P4_FXco ("FINFINITE?", p4_finfinite_q), P4_FXco ("FNAN?", p4_fnan_q), P4_FXco ("FNORMAL?", p4_fnormal_q), P4_FXco ("FSUBNORMAL?", p4_fsubnormal_q), P4_FXco ("FCOPYSIGN", p4_fcopysign), P4_FXco ("FNEXTAFTER", p4_fnextafter), P4_FXco ("FSIGNBIT", p4_fsignbit), P4_FXco ("FNEXTUP", p4_fnextup), P4_FXco ("FNEXTDOWN", p4_fnextdown), P4_FXco ("FREXP", p4_frexp), P4_FXco ("FSCALBN", p4_fscalbn), P4_FXco ("FMODF", p4_fmodf), P4_FXco ("FMODFD", p4_fmodfd), P4_FXco ("FLOGB", p4_flogb), P4_FXco ("FILOGB", p4_filogb), /* floating point text format */ P4_FXco ("FH.", p4_fh_dot), P4_FXco (">IEEEFLOAT", p4_to_ieeefloat), /* floating-point environment */ P4_OCoN ("/FENV", sizeof (fenv_t) ), P4_OCoN ("FE-DFL-ENV", FE_DFL_ENV), P4_FXco ("FEGETENV", p4_fegetenv), P4_FXco ("FESETENV", p4_fesetenv), P4_FXco ("FEHOLDEXCEPT", p4_feholdexcept), P4_FXco ("FEUPDATEENV", p4_feupdateenv), /* floating-point exception flags */ P4_OCoN ("FDIVBYZERO", FE_DIVBYZERO), P4_OCoN ("FINEXACT", FE_INEXACT), P4_OCoN ("FINVALID", FE_INVALID), P4_OCoN ("FOVERFLOW", FE_OVERFLOW), P4_OCoN ("FUNDERFLOW", FE_UNDERFLOW), #if DEFINED_INTEL && !defined __linux__ P4_OCoN ("FDENORMOPAND", FE_DENORMALOPERAND), #endif P4_OCoN ("ALL-FEXCEPTS", FE_ALL_EXCEPT), P4_FXco ("GET-FFLAGS", p4_get_fflags), P4_FXco ("SET-FFLAGS", p4_set_fflags), P4_FXco ("CLEAR-FFLAGS", p4_clear_fflags), /* floating-point rounding modes */ P4_OCoN ("FR-DOWNWARD", FE_DOWNWARD), P4_OCoN ("FR-UPWARD", FE_UPWARD), P4_OCoN ("FR-TONEAREST", FE_TONEAREST), P4_OCoN ("FR-TOWARDZERO", FE_TOWARDZERO), P4_FXco ("GET-FROUND", p4_get_fround), P4_FXco ("SET-FROUND", p4_set_fround), /* alternate floating-point exception handling */ #if DEFINED_PPC P4_FXco ("FPSCR@", p4_fpscr_fetch), P4_FXco ("FPSCR!", p4_fpscr_store), #endif #if DEFINED_INTEL P4_FXco ("X87CR@", p4_x87cr_fetch), P4_FXco ("X87CR!", p4_x87cr_store), P4_FXco ("X87SR@", p4_x87sr_fetch), P4_FXco ("MXCSR@", p4_mxcsr_fetch), P4_FXco ("MXCSR!", p4_mxcsr_store), #endif P4_FXco ("(FENABLE)", p4_paren_fenable), P4_FXco ("(FDISABLE)", p4_paren_fdisable), P4_FXco ("FENABLED", p4_fenabled), P4_FXco ("FEENABLEEXCEPT", p4_feenableexcept), P4_FXco ("FENABLE", p4_fenable), P4_FXco ("FEDISABLEEXCEPT", p4_fedisableexcept), P4_FXco ("FDISABLE", p4_fdisable), P4_FXco ("SET-FHANDLER", p4_set_fhandler), P4_FXco ("GET-FHANDLER", p4_get_fhandler), P4_FXco ("INSTALL-FHANDLING", p4_install_fhandling), P4_INTO ("ENVIRONMENT", 0), P4_OCoN ("IEEE-FP", 2020), P4_XXco ("INSTALL-FHANDLING", p4_install_fhandling), }; P4_COUNTWORDS (ieeefp, "C99 IEEE 754 interface");