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, Devid 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)0x40000000)*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) ((unsigned int)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 -- ) */\r
  52 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
  53                 if( IN_CODE_DIC(TOS) )\r
  54                 {\r
  55                         WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );\r
  56                 }\r
  57                 else\r
  58                 {\r
  59                         *((PF_FLOAT *) TOS) = FP_TOS;\r
  60                 }\r
  61 #else\r
  62                 *((PF_FLOAT *) TOS) = FP_TOS;\r
  63 #endif\r
  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                         uint32 dlo;
 106                         int32 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;\r
 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 = (int32) 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 = (uint32) 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;\r
 140 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))\r
 141                 if( IN_CODE_DIC(TOS) )\r
 142                 {\r
 143                         FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );\r
 144                 }\r
 145                 else\r
 146                 {\r
 147                         FP_TOS = *((PF_FLOAT *) TOS);\r
 148                 }\r
 149 #else\r
 150                 FP_TOS = *((PF_FLOAT *) TOS);\r
 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                 ERR("\nID_FP_FROUND -  Not Yet!! FIXME\n");
 210                 break;
 211
 212         case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */
 213                 fpScratch = FP_TOS;
 214                 FP_TOS = *FP_STKPTR;
 215                 *FP_STKPTR = fpScratch;
 216                 break;
 217
 218         case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */
 219                 fpScratch = M_FP_POP;
 220                 FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS);
 221                 break;
 222
 223         case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */
 224                 FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );
 225                 break;
 226
 227         case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */
 228                 FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );
 229                 break;
 230
 231         case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */
 232                 /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */
 233                 FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1)));
 234                 break;
 235
 236         case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */
 237                 FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);
 238                 break;
 239
 240         case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */
 241                 FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );
 242                 break;
 243
 244         case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */
 245                 /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */
 246                 FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1)));
 247                 break;
 248
 249         case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */
 250                 FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );
 251                 break;
 252
 253         case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */
 254                 fpTemp = M_FP_POP;
 255                 FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );
 256                 break;
 257
 258         case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */
 259                 FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS)));
 260                 break;
 261
 262         case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */
 263                 FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );
 264                 break;
 265
 266         case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */
 267                 FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );
 268                 break;
 269
 270 #ifndef PF_NO_SHELL
 271         case ID_FP_FLITERAL:
 272                 ffFPLiteral( FP_TOS );
 273                 M_FP_DROP;
 274                 endcase;
 275 #endif  /* !PF_NO_SHELL */
 276
 277         case ID_FP_FLITERAL_P:
 278                 PUSH_FP_TOS;
 279 #if 0
 280 /* Some wimpy compilers can't handle this! */
 281                 FP_TOS = *(((PF_FLOAT *)InsPtr)++);
 282 #else
 283                 {
 284                         PF_FLOAT *fptr;
 285                         fptr = (PF_FLOAT *)InsPtr;\r
 286                         FP_TOS = READ_FLOAT_DIC( fptr++ );
 287                         InsPtr = (cell *) fptr;
 288                 }
 289 #endif
 290                 endcase;
 291
 292         case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
 293                 FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
 294                 break;
 295
 296         case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
 297                 FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
 298                 break;
 299
 300         case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
 301                 FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
 302                 break;
 303
 304         case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
 305                 FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
 306                 break;
 307
 308         case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */
 309                 M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));
 310                 FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);
 311                 break;
 312
 313         case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
 314                 FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
 315                 break;
 316
 317         case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
 318                 FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
 319                 break;
 320
 321         case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
 322                 FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
 323                 break;
 324
 325         case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
 326                 FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
 327                 break;
 328
 329         case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */
 330                 PUSH_FP_TOS;  /* push cached floats into RAM */
 331                 FP_TOS = FP_STKPTR[TOS];  /* 0 FPICK gets top of FP stack */
 332                 M_DROP;
 333                 break;
 334
 335
 336 #endif