git.gag.com Git - debian/pforth/blob - csrc/pfinnrfp.h

   1 /*  @(#) pfinnrfp.h 98/02/26 1.4 */
   2 /***************************************************************
   3 ** Compile FP routines.
   4 ** This file is included from "pf_inner.c"
   5 **
   6 ** These routines could be left out of an execute only version.
   7 **
   8 ** Author: Darren Gibbs, Phil Burk
   9 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
  10 **
  11 ** Permission to use, copy, modify, and/or distribute this
  12 ** software for any purpose with or without fee is hereby granted.
  13 **
  14 ** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
  15 ** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
  16 ** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
  17 ** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
  18 ** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
  19 ** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
  20 ** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  21 ** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  22 **
  23 ****************************************************************
  24 **
  25 ***************************************************************/
  26
  27 #ifdef PF_SUPPORT_FP
  28
  29 #define FP_DHI1 (((PF_FLOAT)((cell_t)1<<(sizeof(cell_t)*8-2)))*4.0)
  30
  31     case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */
  32         PUSH_FP_TOS;
  33         Scratch = M_POP; /* dlo */
  34         DBUG(("dlo = 0x%8x , ", Scratch));
  35         DBUG(("dhi = 0x%8x\n", TOS));
  36
  37         if( ((TOS ==  0) && (Scratch >= 0)) ||
  38             ((TOS == -1) && (Scratch < 0)))
  39         {
  40             /* <=  32 bit precision. */
  41             FP_TOS = ((PF_FLOAT) Scratch);  /* Convert dlo and push on FP stack. */
  42         }
  43         else /* > 32 bit precision. */
  44         {
  45             fpTemp = ((PF_FLOAT) TOS); /* dhi */
  46             fpTemp *= FP_DHI1;
  47             fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) );  /* Convert TOS and push on FP stack. */
  48             FP_TOS = fpTemp + fpScratch;
  49         }
  50         M_DROP;
  51         /* printf("d2f = %g\n", FP_TOS); */
  52         break;
  53
  54     case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */
  55 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
  56         if( IN_CODE_DIC(TOS) )
  57         {
  58             WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );
  59         }
  60         else
  61         {
  62             *((PF_FLOAT *) TOS) = FP_TOS;
  63         }
  64 #else
  65         *((PF_FLOAT *) TOS) = FP_TOS;
  66 #endif
  67         M_FP_DROP;      /* drop FP value */
  68         M_DROP;         /* drop addr */
  69         break;
  70
  71     case ID_FP_FTIMES:  /* ( F: r1 r2 -- r1*r2 ) */
  72         FP_TOS = M_FP_POP * FP_TOS;
  73         break;
  74
  75     case ID_FP_FPLUS:  /* ( F: r1 r2 -- r1+r2 ) */
  76         FP_TOS = M_FP_POP + FP_TOS;
  77         break;
  78
  79     case ID_FP_FMINUS:  /* ( F: r1 r2 -- r1-r2 ) */
  80         FP_TOS = M_FP_POP - FP_TOS;
  81         break;
  82
  83     case ID_FP_FSLASH:  /* ( F: r1 r2 -- r1/r2 ) */
  84         FP_TOS = M_FP_POP / FP_TOS;
  85         break;
  86
  87     case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag )  ( F: r --  ) */
  88         PUSH_TOS;
  89         TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;
  90         M_FP_DROP;
  91         break;
  92
  93     case ID_FP_F_ZERO_EQUALS: /* ( -- flag )  ( F: r --  ) */
  94         PUSH_TOS;
  95         TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;
  96         M_FP_DROP;
  97         break;
  98
  99     case ID_FP_F_LESS_THAN: /* ( -- flag )  ( F: r1 r2 -- ) */
 100         PUSH_TOS;
 101         TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;
 102         M_FP_DROP;
 103         break;
 104
 105     case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */
 106         /* printf("f2d = %g\n", FP_TOS); */
 107         {
 108             ucell_t dlo;
 109             cell_t dhi;
 110             int ifNeg;
 111     /* Convert absolute value, then negate D if negative. */
 112             PUSH_TOS;   /* Save old TOS */
 113             fpTemp = FP_TOS;
 114             M_FP_DROP;
 115             ifNeg = (fpTemp < 0.0);
 116             if( ifNeg )
 117             {
 118                 fpTemp = 0.0 - fpTemp;
 119             }
 120             fpScratch = fpTemp / FP_DHI1;
 121         /* printf("f2d - fpScratch = %g\n", fpScratch); */
 122             dhi = (cell_t) fpScratch;  /* dhi */
 123             fpScratch = ((PF_FLOAT) dhi) * FP_DHI1;
 124         /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */
 125
 126             fpTemp = fpTemp - fpScratch; /* Remainder */
 127             dlo = (ucell_t) fpTemp;
 128         /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */
 129             if( ifNeg )
 130             {
 131                 dlo = 0 - dlo;
 132                 dhi = 0 - dhi - 1;
 133             }
 134     /* Push onto stack. */
 135             TOS = dlo;
 136             PUSH_TOS;
 137             TOS = dhi;
 138         }
 139         break;
 140
 141     case ID_FP_FFETCH:  /* ( addr -- ) ( F: -- r ) */
 142         PUSH_FP_TOS;
 143 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
 144         if( IN_CODE_DIC(TOS) )
 145         {
 146             FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );
 147         }
 148         else
 149         {
 150             FP_TOS = *((PF_FLOAT *) TOS);
 151         }
 152 #else
 153         FP_TOS = *((PF_FLOAT *) TOS);
 154 #endif
 155         M_DROP;
 156         break;
 157
 158     case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */
 159         PUSH_TOS;
 160     /* Add 1 to account for FP_TOS in cached in register. */
 161         TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);
 162         break;
 163
 164     case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */
 165         M_FP_DROP;
 166         break;
 167
 168     case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */
 169         PUSH_FP_TOS;
 170         break;
 171
 172     case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */
 173         TOS = TOS + sizeof(PF_FLOAT);
 174         break;
 175
 176     case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */
 177         TOS = TOS * sizeof(PF_FLOAT);
 178         break;
 179
 180     case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */
 181         FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );
 182         break;
 183
 184     case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */
 185         fpScratch = M_FP_POP;
 186         FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ;
 187         break;
 188
 189     case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */
 190         fpScratch = M_FP_POP;
 191         FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ;
 192         break;
 193
 194     case ID_FP_FNEGATE:
 195         FP_TOS = -FP_TOS;
 196         break;
 197
 198     case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */
 199         PUSH_FP_TOS;
 200         FP_TOS = M_FP_STACK(1);
 201         break;
 202
 203     case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */
 204         fpScratch = M_FP_POP;       /* r2 */
 205         fpTemp = M_FP_POP;          /* r1 */
 206         M_FP_PUSH( fpScratch );     /* r2 */
 207         PUSH_FP_TOS;                /* r3 */
 208         FP_TOS = fpTemp;            /* r1 */
 209         break;
 210
 211     case ID_FP_FROUND:
 212         /* This was broken before and used to push its result to the
 213          * integer data stack! Now it conforms to the ANSI standard.
 214          * https://github.com/philburk/pforth/issues/69
 215          */
 216         FP_TOS = (PF_FLOAT)fp_round(FP_TOS);
 217         break;
 218
 219     case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */
 220         fpScratch = FP_TOS;
 221         FP_TOS = *FP_STKPTR;
 222         *FP_STKPTR = fpScratch;
 223         break;
 224
 225     case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */
 226         fpScratch = M_FP_POP;
 227         FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS);
 228         break;
 229
 230     case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */
 231         FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );
 232         break;
 233
 234     case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */
 235         FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );
 236         break;
 237
 238     case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */
 239         /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */
 240         FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1)));
 241         break;
 242
 243     case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */
 244         FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);
 245         break;
 246
 247     case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */
 248         FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );
 249         break;
 250
 251     case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */
 252         /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */
 253         FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1)));
 254         break;
 255
 256     case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */
 257         FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );
 258         break;
 259
 260     case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */
 261         fpTemp = M_FP_POP;
 262         FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );
 263         break;
 264
 265     case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */
 266         FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS)));
 267         break;
 268
 269     case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */
 270         FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );
 271         break;
 272
 273     case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */
 274         FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );
 275         break;
 276
 277 #ifndef PF_NO_SHELL
 278     case ID_FP_FLITERAL:
 279         ffFPLiteral( FP_TOS );
 280         M_FP_DROP;
 281         endcase;
 282 #endif  /* !PF_NO_SHELL */
 283
 284     case ID_FP_FLITERAL_P:
 285         PUSH_FP_TOS;
 286 #if 0
 287 /* Some wimpy compilers can't handle this! */
 288         FP_TOS = *(((PF_FLOAT *)InsPtr)++);
 289 #else
 290         {
 291             PF_FLOAT *fptr;
 292             fptr = (PF_FLOAT *)InsPtr;
 293             FP_TOS = READ_FLOAT_DIC( fptr++ );
 294             InsPtr = (cell_t *) fptr;
 295         }
 296 #endif
 297         endcase;
 298
 299     case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
 300         FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
 301         break;
 302
 303     case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
 304         FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
 305         break;
 306
 307     case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
 308         FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
 309         break;
 310
 311     case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
 312         FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
 313         break;
 314
 315     case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */
 316         M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));
 317         FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);
 318         break;
 319
 320     case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
 321         FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
 322         break;
 323
 324     case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
 325         FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
 326         break;
 327
 328     case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
 329         FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
 330         break;
 331
 332     case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
 333         FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
 334         break;
 335
 336     case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */
 337         PUSH_FP_TOS;  /* push cached floats into RAM */
 338         FP_TOS = FP_STKPTR[TOS];  /* 0 FPICK gets top of FP stack */
 339         M_DROP;
 340         break;
 341
 342
 343 #endif