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

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