/* ^Forth: Floating Point Words File: hffloat.hf Author/Deriver: david.n.williams@umich.edu Version: 0.1.6 License: LGPL Last revision: December 6, 2002 Copyright (C) 1995 Dirk Uwe Zoller Copyright (C) 1998-2001 Tektronix, Inc. Copyright (C) 2001-2002 David N. Williams This library is part of ^Forth. It is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. Please see the file POLITENESS included with this distribution. Much code is copied from pfe. */ BEGIN-EXTERNAL {" /* Extra includes. */ #include #include #include #include #include #include #if !defined PFE_HAVE_ACOSH /* * Simple acosh(), asinh(), atanh() for those unfortunates who don't * have them. These are oversimplified routines (no error or boundry * checking). !!! DONT TRUST THESE ROUTINES !!! */ static double acosh (double n) { return log (n + sqrt (n * n - 1)); } static double asinh (double n) { return (n < 0 ? -1.0 : 1.0) * log (fabs (n) + sqrt (n * n + 1)); } static double atanh (double n) { return log (1.0 + ((2.0 * n) / (1.0 - n))) * 0.5; } #endif /* PFE_HAVE_ACOSH */ #if !defined HAVE_POW10 && !defined PFE_HAVE_POW10 #define pow10(X) pow(10.0,(X)) #endif p4cell hf_dfaligned (p4cell n) { while (!P4_DFALIGNED (n)) n++; return n; } "} /* No REQUIRES. */ END-EXTERNAL MAKE-INDEX hffloat "^Forth Floating-Point Word Set" \ decimal /* Words ******************************** \ *** Glossary >float d>f df df! df@ dfalign dfaligned dfloat+ dfloats f! f* f** f+ f- f. f/ f0< f0= f< f<= f<> f= f> f>= f>d f@ falign faligned fdepth fdrop fdup fe. flit float+ floats floor fmax fmin fnegate fover fp@ fp! frot fround fs. fswap f~ precision represent set-precision sf! sf@ sfalign sfaligned sfloat+ sfloats fabs facos facosh falog fasin fasinh fatan fatan2 fatanh fcos fcosh fexp fexpm1 fln flnp1 flog fsin fsincos fsinh fsqrt ftan ftanh F0 FLOAT-INPUT */ \ *** System Variables \ PFE ext-variable: F0 "f0" ext-variable: FLOAT-INPUT "float_input" \ *** Glossary \ FLOATING ext-def: >FLOAT "to_float" ( f.s -- true|false f: -- f| ) ext-def: d>f "d_to_f" ( d -- f: f ) defm: F! "f_store" (f: f s: addr -- ) *(double *) TOS = FTOS; HF_DROP1; HF_FDROP1; ;defm defm: F* "f_star" (f: f1 f2 -- f ) { double res = FTOS * FP[1]; FP++; FTOS = res; } ;defm defm: F+ "f_plus" (f: f1 f2 -- f ) { double res = FTOS + FP[1]; FP++; FTOS = res; } ;defm defm: F- "f_minus" (f: f1 f2 -- f ) { double res = FP[1] - FTOS; FP++; FTOS = res; } ;defm defm: F/ "f_slash" (f: numer denom -- quot ) { double res = FP[1] / FTOS; FP++; FTOS = res; } ;defm; defm: F0< "f_zero_less" (f: f -- s: flag ) HF_PUSH (P4_FLAG (FTOS < 0)); HF_FDROP1; ;defm defm: F0= "f_zero_equal" (f: f -- s: flag ) HF_PUSH (P4_FLAG (FTOS == 0)); HF_FDROP1; ;defm defm: F< "f_less_than" (f: x y -- s: flag ) HF_PUSH (P4_FLAG (FTOS > FP[1])); HF_FDROP2; ;defm ext-def: F>D "f_to_d" (f: f -- s: d ) defm: F@ "f_fetch" (s: addr -- f: f ) HF_FPUSH (*(double *) TOS); HF_DROP1; ;defm defm: FDEPTH "f_depth" ( -- n ) #ifdef HF_TOSREG *SP = TOS; TOS = p4_F0 - FP; SP--; #else { p4cell diff = p4_F0 - FP; *--SP = diff; } #endif ;defm defm: FDROP "f_drop" (f: f -- ) HF_FDROP1; ;defm defm: FDUP "f_dup" (f: f -- f f ) #ifdef HF_FTOSREG *FP-- = FTOS; #else FP--; FP[0] = FP[1]; #endif ;defm defm: FLOOR "floor" (f: f -- f' ) FTOS = floor (FTOS); ;defm defm: FMAX "f_max" (f: f1 f2 -- f ) { double res = (FTOS > FP[1]) ? FTOS : FP[1]; FP++; FTOS = res; } ;defm defm: FMIN "f_min" (f: f1 f2 -- f ) { double res = (FTOS < FP[1]) ? FTOS : FP[1]; FP++; FTOS = res; } ;defm defm: FNEGATE "f_negate" (f: f -- -f ) FTOS = -FTOS; ;defm defm: FOVER "f_over" (f: x y -- x y x ) HF_SPILL_FTOS --FP; FTOS = FP[2]; ;defm defm: FROT "f_rot" (f: x y z -- y z x ) { double h = FP[2]; FP[2] = FP[1]; FP[1] = FTOS; FTOS = h; } ;defm ext-def: FROUND "f_round" (r: f -- f' ) defm: FSWAP "f_swap" (f: x y -- y x ) { double h = FP[1]; FP[1] = FTOS; FTOS = h; } ;defm ext-def: REPRESENT "represent" ( significand.s -- n flag1 flag2 ) (r: f -- ) \ FLOATING EXT defm: DFALIGN "d_f_align" ( -- ) while (!P4_DFALIGNED (DP)) *DP++ = 0; ;defm defm: DFALIGNED "d_f_aligned" ( addr -- df-addr ) FTOS = hf_dfaligned (FTOS); ;defm defm: DFLOAT+ "d_float_plus" ( df-addr1 -- df-addr2 ) TOS += sizeof (double); ;defm defm: DFLOATS "d_floats" ( n1 -- n2 ) TOS *= sizeof (double); ;defm defm: FLOAT+ "float_plus" ( df-addr1 -- df-addr2 ) TOS += sizeof (double); ;defm defm: FLOATS "floats" ( n1 -- n2 ) TOS *= sizeof (double); ;defm defm: F** "f_star_star" (f: x y -- z ) { double res = pow (FP[1], FTOS); FP++; TOS = res; } ;defm ext-def: F. "f_dot" (f: f -- ) defm: FABS "f_abs" (f: f -- |f| ) if (FTOS < 0) FTOS = -FTOS; ;defm ext-def: FE. "f_e_dot" (f: f -- ) ext-def: FS. "f_s_dot" (f: f -- ) def: F~ "f_proximate" (r: x y z -- s: flag ) c{ double a, b, c; a = FP[2]; b = FP[1]; c = FTOS; HF_FDROP3; HF_PUSH (P4_FLAG( c > 0 ? fabs (a - b) < c : c < 0 ? fabs (a - b) < -c * (fabs (a) + fabs (b)) : a == b)); }c ;def defm: PRECISION "precision" ( -- u ) HF_PUSH (PRECISION); ;defm defm: SET-PRECISION "set_precision" ( u -- ) PRECISION = TOS; SP++; ;defm defm: SF! "s_f_store" (r: f s: sf-addr -- ) *(float *) TOS = FTOS; HF_DROP1; HF_FDROP1; ;defm defm: SF@ "s_f_fetch" ( sf-addr -- f: f ) HF_FPUSH (*(float *) TOS); HF_DROP1; ;defm defm: SFLOAT+ "s_float_plus" ( sf-addr1 -- sf-addr2 ) TOS += sizeof (float); ;defm defm: SFLOATS "s_floats" ( n1 -- n2 ) TOS *= sizeof (float); ;defm defm: FACOS "f_acos" (f: x -- y ) FTOS = acos (FTOS); ;defm defm: FACOSH "f_acosh" (f: x -- y ) FTOS = acosh (FTOS); ;defm defm: FALOG "f_alog" (f: x -- y ) FTOS = pow10 (FTOS); ;defm defm: FASIN "f_asin" (f: x -- y ) FTOS = asin (FTOS); ;defm defm: FASINH "f_asinh" (f: x -- y ) FTOS = asinh (FTOS); ;defm defm: FATAN "f_atan" (f: x -- y ) FTOS = atan (FTOS); ;defm defm: FATAN2 "f_atan2" (f: x1 x2 -- y ) { double res = atan2 (FP [1], FTOS); FP++; FTOS = res; } ;defm defm: FATANH "f_atanh" (f: x -- y ) FTOS = atanh (FTOS); ;defm defm: FCOS "f_cos" (f: x -- y ) FTOS = cos (FTOS); ;defm defm: FCOSH "f_cosh" (f: x -- y ) FTOS = cosh (FTOS); ;defm defm: FEXP "f_exp" (f: x -- y ) FTOS = exp (FTOS); ;defm defm: FEXPM1 "f_expm1" (f: x -- y ) FTOS = exp (FTOS) - 1.0; ;defm defm: FLN "f_ln" (f: x -- y ) FTOS = log (FTOS); ;defm defm: FLNP1 "f_lnp1" (f: x -- y ) FTOS = log (FTOS + 1.0); ;defm defm: FLOG "f_log" (f: x -- y ) FTOS = log10 (FTOS); ;defm defm: FSIN "f_sin" (f: x -- y ) FTOS = sin (FTOS); ;defm defm: FSINCOS "f_sincos" (f: x -- y1 y2 ) { double x = FTOS; *FP-- = sin (x); FTOS = cos (x) ; } ;defm defm: FSINH "f_sinh" (f: x -- y ) FTOS = sinh (FTOS); ;defm defm: FSQRT "f_sqrt" (f: x -- y ) FTOS = sqrt (FTOS); ;defm defm: FTAN "f_tan" (f: x -- y ) FTOS = tan (FTOS); ;defm defm: FTANH "f_tanh" (f: x -- y ) FTOS = tanh (FTOS); ;defm \ PFE defm: FP@ "f_p_fetch" ( -- addr ) HF_PUSH ((p4cell) FP); ;defm defm: FP! "f_p_store" ( addr -- ) FP = (double *) TOS; HF_DROP1; ;defm defm: F= "f_equal" (f: x y -- s: flag ) HF_PUSH (P4_FLAG (FTOS == FP[1])); HF_FDROP2; ;defm defm: F<> "f_not_equal" (f: x y -- s: flag ) HF_PUSH (P4_FLAG (FTOS != FP[1])); HF_FDROP2; ;defm defm: F> "f_greater_than" (f: x y -- s: flag ) HF_PUSH (P4_FLAG (FTOS < FP[1])); HF_FDROP2; ;defm defm: F<= "f_less_than_or_equal" (f: x y -- s: flag ) HF_PUSH (P4_FLAG (FTOS >= FP[1])); HF_FDROP2; ;defm defm: F>= "f_greater_than_or_equal" (f: x y -- s: flag ) HF_PUSH (P4_FLAG (FTOS <= FP[1])); HF_FDROP2; ;defm