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 ** The pForth software code is dedicated to the public domain,
  12 ** and any third party may reproduce, distribute and modify
  13 ** the pForth software code or any derivative works thereof
  14 ** without any compensation or license.  The pForth software
  15 ** code is provided on an "as is" basis without any warranty
  16 ** of any kind, including, without limitation, the implied
  17 ** warranties of merchantability and fitness for a particular
  18 ** purpose and their equivalents under the laws of any jurisdiction.
  19 **
  20 ****************************************************************
  21 **
  22 ***************************************************************/
  23
  24 #ifdef PF_SUPPORT_FP
  25
  26 #define FP_DHI1 (((PF_FLOAT)(1L<<(sizeof(cell_t)*8-2)))*4.0)
  27
  28     case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */
  29         PUSH_FP_TOS;
  30         Scratch = M_POP; /* dlo */
  31         DBUG(("dlo = 0x%8x , ", Scratch));
  32         DBUG(("dhi = 0x%8x\n", TOS));
  33
  34         if( ((TOS ==  0) && (Scratch >= 0)) ||
  35             ((TOS == -1) && (Scratch < 0)))
  36         {
  37             /* <=  32 bit precision. */
  38             FP_TOS = ((PF_FLOAT) Scratch);  /* Convert dlo and push on FP stack. */
  39         }
  40         else /* > 32 bit precision. */
  41         {
  42             fpTemp = ((PF_FLOAT) TOS); /* dhi */
  43             fpTemp *= FP_DHI1;
  44             fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) );  /* Convert TOS and push on FP stack. */
  45             FP_TOS = fpTemp + fpScratch;
  46         }
  47         M_DROP;
  48         /* printf("d2f = %g\n", FP_TOS); */
  49         break;
  50
  51     case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */
  52 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
  53         if( IN_CODE_DIC(TOS) )
  54         {
  55             WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );
  56         }
  57         else
  58         {
  59             *((PF_FLOAT *) TOS) = FP_TOS;
  60         }
  61 #else
  62         *((PF_FLOAT *) TOS) = FP_TOS;
  63 #endif
  64         M_FP_DROP;      /* drop FP value */
  65         M_DROP;         /* drop addr */
  66         break;
  67
  68     case ID_FP_FTIMES:  /* ( F: r1 r2 -- r1*r2 ) */
  69         FP_TOS = M_FP_POP * FP_TOS;
  70         break;
  71
  72     case ID_FP_FPLUS:  /* ( F: r1 r2 -- r1+r2 ) */
  73         FP_TOS = M_FP_POP + FP_TOS;
  74         break;
  75
  76     case ID_FP_FMINUS:  /* ( F: r1 r2 -- r1-r2 ) */
  77         FP_TOS = M_FP_POP - FP_TOS;
  78         break;
  79
  80     case ID_FP_FSLASH:  /* ( F: r1 r2 -- r1/r2 ) */
  81         FP_TOS = M_FP_POP / FP_TOS;
  82         break;
  83
  84     case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag )  ( F: r --  ) */
  85         PUSH_TOS;
  86         TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;
  87         M_FP_DROP;
  88         break;
  89
  90     case ID_FP_F_ZERO_EQUALS: /* ( -- flag )  ( F: r --  ) */
  91         PUSH_TOS;
  92         TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;
  93         M_FP_DROP;
  94         break;
  95
  96     case ID_FP_F_LESS_THAN: /* ( -- flag )  ( F: r1 r2 -- ) */
  97         PUSH_TOS;
  98         TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;
  99         M_FP_DROP;
 100         break;
 101
 102     case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */
 103         /* printf("f2d = %g\n", FP_TOS); */
 104         {
 105             ucell_t dlo;
 106             cell_t dhi;
 107             int ifNeg;
 108     /* Convert absolute value, then negate D if negative. */
 109             PUSH_TOS;   /* Save old TOS */
 110             fpTemp = FP_TOS;
 111             M_FP_DROP;
 112             ifNeg = (fpTemp < 0.0);
 113             if( ifNeg )
 114             {
 115                 fpTemp = 0.0 - fpTemp;
 116             }
 117             fpScratch = fpTemp / FP_DHI1;
 118         /* printf("f2d - fpScratch = %g\n", fpScratch); */
 119             dhi = (cell_t) fpScratch;  /* dhi */
 120             fpScratch = ((PF_FLOAT) dhi) * FP_DHI1;
 121         /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */
 122
 123             fpTemp = fpTemp - fpScratch; /* Remainder */
 124             dlo = (ucell_t) fpTemp;
 125         /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */
 126             if( ifNeg )
 127             {
 128                 dlo = 0 - dlo;
 129                 dhi = 0 - dhi - 1;
 130             }
 131     /* Push onto stack. */
 132             TOS = dlo;
 133             PUSH_TOS;
 134             TOS = dhi;
 135         }
 136         break;
 137
 138     case ID_FP_FFETCH:  /* ( addr -- ) ( F: -- r ) */
 139         PUSH_FP_TOS;
 140 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
 141         if( IN_CODE_DIC(TOS) )
 142         {
 143             FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );
 144         }
 145         else
 146         {
 147             FP_TOS = *((PF_FLOAT *) TOS);
 148         }
 149 #else
 150         FP_TOS = *((PF_FLOAT *) TOS);
 151 #endif
 152         M_DROP;
 153         break;
 154
 155     case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */
 156         PUSH_TOS;
 157     /* Add 1 to account for FP_TOS in cached in register. */
 158         TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);
 159         break;
 160
 161     case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */
 162         M_FP_DROP;
 163         break;
 164
 165     case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */
 166         PUSH_FP_TOS;
 167         break;
 168
 169     case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */
 170         TOS = TOS + sizeof(PF_FLOAT);
 171         break;
 172
 173     case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */
 174         TOS = TOS * sizeof(PF_FLOAT);
 175         break;
 176
 177     case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */
 178         FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );
 179         break;
 180
 181     case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */
 182         fpScratch = M_FP_POP;
 183         FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ;
 184         break;
 185
 186     case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */
 187         fpScratch = M_FP_POP;
 188         FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ;
 189         break;
 190
 191     case ID_FP_FNEGATE:
 192         FP_TOS = -FP_TOS;
 193         break;
 194
 195     case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */
 196         PUSH_FP_TOS;
 197         FP_TOS = M_FP_STACK(1);
 198         break;
 199
 200     case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */
 201         fpScratch = M_FP_POP;       /* r2 */
 202         fpTemp = M_FP_POP;          /* r1 */
 203         M_FP_PUSH( fpScratch );     /* r2 */
 204         PUSH_FP_TOS;                /* r3 */
 205         FP_TOS = fpTemp;            /* r1 */
 206         break;
 207
 208     case ID_FP_FROUND:
 209         PUSH_TOS;
 210         TOS = fp_round(FP_TOS);
 211         M_FP_DROP;
 212         break;
 213
 214     case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */
 215         fpScratch = FP_TOS;
 216         FP_TOS = *FP_STKPTR;
 217         *FP_STKPTR = fpScratch;
 218         break;
 219
 220     case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */
 221         fpScratch = M_FP_POP;
 222         FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS);
 223         break;
 224
 225     case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */
 226         FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );
 227         break;
 228
 229     case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */
 230         FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );
 231         break;
 232
 233     case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */
 234         /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */
 235         FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1)));
 236         break;
 237
 238     case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */
 239         FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);
 240         break;
 241
 242     case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */
 243         FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );
 244         break;
 245
 246     case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */
 247         /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */
 248         FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1)));
 249         break;
 250
 251     case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */
 252         FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );
 253         break;
 254
 255     case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */
 256         fpTemp = M_FP_POP;
 257         FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );
 258         break;
 259
 260     case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */
 261         FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS)));
 262         break;
 263
 264     case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */
 265         FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );
 266         break;
 267
 268     case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */
 269         FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );
 270         break;
 271
 272 #ifndef PF_NO_SHELL
 273     case ID_FP_FLITERAL:
 274         ffFPLiteral( FP_TOS );
 275         M_FP_DROP;
 276         endcase;
 277 #endif  /* !PF_NO_SHELL */
 278
 279     case ID_FP_FLITERAL_P:
 280         PUSH_FP_TOS;
 281 #if 0
 282 /* Some wimpy compilers can't handle this! */
 283         FP_TOS = *(((PF_FLOAT *)InsPtr)++);
 284 #else
 285         {
 286             PF_FLOAT *fptr;
 287             fptr = (PF_FLOAT *)InsPtr;
 288             FP_TOS = READ_FLOAT_DIC( fptr++ );
 289             InsPtr = (cell_t *) fptr;
 290         }
 291 #endif
 292         endcase;
 293
 294     case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
 295         FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
 296         break;
 297
 298     case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
 299         FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
 300         break;
 301
 302     case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
 303         FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
 304         break;
 305
 306     case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
 307         FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
 308         break;
 309
 310     case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */
 311         M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));
 312         FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);
 313         break;
 314
 315     case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
 316         FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
 317         break;
 318
 319     case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
 320         FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
 321         break;
 322
 323     case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
 324         FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
 325         break;
 326
 327     case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
 328         FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
 329         break;
 330
 331     case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */
 332         PUSH_FP_TOS;  /* push cached floats into RAM */
 333         FP_TOS = FP_STKPTR[TOS];  /* 0 FPICK gets top of FP stack */
 334         M_DROP;
 335         break;
 336
 337
 338 #endif