git.gag.com Git - debian/yforth/blob - floate.c

   1 /* yForth? - A Forth interpreter written in ANSI C
   2  * Copyright (C) 2012 Luca Padovani
   3  *
   4  * This program is free software: you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 3 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16  * ------------------------------------------------------------------------
  17  * Module name:     floate.c
  18  * Abstract:        floating-extension word set
  19  */
  20
  21 #include <stdio.h>
  22 #include <math.h>
  23 #include "yforth.h"
  24 #include "floate.h"
  25
  26 /**************************************************************************/
  27 /* VARIABLES **************************************************************/
  28 /**************************************************************************/
  29
  30 static Cell precision = 15;
  31
  32 /**************************************************************************/
  33 /* WORDS ******************************************************************/
  34 /**************************************************************************/
  35
  36 void _d_f_store() {
  37     register double *addr = (double *) *sp++;
  38     *addr = (double) *fp++;
  39 }
  40
  41 void _d_f_fetch() {
  42     register double *addr = (double *) *sp++;
  43     *--fp = (Real) *addr;
  44 }
  45
  46 void _d_float_plus() {
  47     sp[0] += sizeof(double);
  48 }
  49
  50 void _d_floats() {
  51     sp[0] *= sizeof(double);
  52 }
  53
  54 void _f_star_star() {
  55     fp[1] = pow(fp[1], fp[0]);
  56     fp++;
  57 }
  58
  59 void _f_dot() {
  60     printf("%.*f ", precision, (double) *fp++);
  61 }
  62
  63 void _f_abs() {
  64     *fp = fabs(*fp);
  65 }
  66
  67 void _f_a_cos() {
  68     *fp = acos(*fp);
  69 }
  70
  71 void _f_a_cosh() {
  72 #ifdef HAVE_ACOSH
  73         *fp = acosh(*fp);
  74 #else
  75         *fp = log(*fp + sqrt(*fp * *fp - 1));
  76 #endif
  77 }
  78
  79 void _f_a_log() {
  80     *fp = pow(10, *fp);
  81 }
  82
  83 void _f_a_sin() {
  84     *fp = asin(*fp);
  85 }
  86
  87 void _f_a_sinh() {
  88 #ifdef HAVE_ASINH
  89         *fp = asinh(*fp);
  90 #else
  91         *fp = log(*fp + sqrt(*fp * *fp + 1));
  92 #endif
  93 }
  94
  95 void _f_a_tan() {
  96     *fp = atan(*fp);
  97 }
  98
  99 void _f_a_tan2() {
 100         fp[1] = atan2(fp[1], fp[0]);
 101     fp++;
 102 }
 103
 104 void _f_a_tanh() {
 105 #ifdef HAVE_ATANH
 106         *fp = atanh(*fp);
 107 #else
 108         *fp = 0.5 * log((1 + *fp) / (1 - *fp));
 109 #endif
 110 }
 111
 112 void _f_cos() {
 113     *fp = cos(*fp);
 114 }
 115
 116 void _f_cosh() {
 117     *fp = cosh(*fp);
 118 }
 119
 120 void _f_e_dot() {
 121     register Real r = *fp++;
 122     register int esp = 0;
 123     if (r != 0.0)
 124         while (r < 1.0 || r > 1000.0) {
 125             if (r < 1.0) {
 126                 r *= 1000.0;
 127                 esp -= 3;
 128             } else {
 129                 r /= 1000.0;
 130                 esp += 3;
 131             }
 132         }
 133     printf("%.*fE%d ", precision, (double) r, esp);
 134 }
 135
 136 void _f_exp() {
 137     *fp = exp(*fp);
 138 }
 139
 140 void _f_exp_m_one() {
 141     *fp = exp(*fp) - 1.0;
 142 }
 143
 144 void _f_ln() {
 145     *fp = log(*fp);
 146 }
 147
 148 void _f_ln_p_one() {
 149     *fp = log(*fp) + 1.0;
 150 }
 151
 152 void _f_log() {
 153     *fp = log10(*fp);
 154 }
 155
 156 void _f_s_dot() {
 157     printf("%.*e ", precision, (double) *fp++);
 158 }
 159
 160 void _f_sin() {
 161     *fp = sin(*fp);
 162 }
 163
 164 void _f_sin_cos() {
 165     fp--;
 166     fp[0] = cos(fp[1]);
 167     fp[1] = sin(fp[1]);
 168 }
 169
 170 void _f_sinh() {
 171     *fp = sinh(*fp);
 172 }
 173
 174 void _f_sqrt() {
 175     *fp = sqrt(*fp);
 176 }
 177
 178 void _f_tan() {
 179     *fp = tan(*fp);
 180 }
 181
 182 void _f_tanh() {
 183     *fp = tanh(*fp);
 184 }
 185
 186 void _f_proximate() {
 187     register Real r3 = *fp++;
 188     register Real r2 = *fp++;
 189     register Real r1 = *fp++;
 190     if (r3 > 0.0) *--sp = FFLAG(fabs(r1 - r2) < r3);
 191     else if (r3 < 0.0) *--sp = FFLAG(fabs(r1 - r2) < (-r3) * (fabs(r1) + fabs(r2)));
 192     else *--sp = FFLAG(r1 == r2);
 193 }
 194
 195 void _precision() {
 196     *--sp = precision;
 197 }
 198
 199 void _set_precision() {
 200     precision = *sp++;
 201 }
 202
 203 void _s_f_store() {
 204     register float *addr = (float *) *sp++;
 205     *addr = (float) *fp++;
 206 }
 207
 208 void _s_f_fetch() {
 209     register float *addr = (float *) *sp++;
 210         *--fp = (Real) *addr;
 211 }
 212
 213 void _s_float_plus() {
 214     sp[0] += sizeof(float);
 215 }
 216
 217 void _s_floats() {
 218     sp[0] *= sizeof(float);
 219 }
 220