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

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