| 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 | |
| 26 | #define FP_DHI1 (((PF_FLOAT)(1L<<(sizeof(cell_t)*8-2)))*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 |