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
6 ** These routines could be left out of an execute only version.
\r
8 ** Author: Darren Gibbs, Phil Burk
\r
9 ** Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
\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
20 ****************************************************************
\r
22 ***************************************************************/
\r
24 #ifdef PF_SUPPORT_FP
\r
26 #define FP_DHI1 (((PF_FLOAT)0x40000000)*4.0)
\r
28 case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */
\r
30 Scratch = M_POP; /* dlo */
\r
31 DBUG(("dlo = 0x%8x , ", Scratch));
\r
32 DBUG(("dhi = 0x%8x\n", TOS));
\r
34 if( ((TOS == 0) && (Scratch >= 0)) ||
\r
35 ((TOS == -1) && (Scratch < 0)))
\r
37 /* <= 32 bit precision. */
\r
38 FP_TOS = ((PF_FLOAT) Scratch); /* Convert dlo and push on FP stack. */
\r
40 else /* > 32 bit precision. */
\r
42 fpTemp = ((PF_FLOAT) TOS); /* dhi */
\r
44 fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) ); /* Convert TOS and push on FP stack. */
\r
45 FP_TOS = fpTemp + fpScratch;
\r
48 /* printf("d2f = %g\n", FP_TOS); */
\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
55 WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );
\r
59 *((PF_FLOAT *) TOS) = FP_TOS;
\r
62 *((PF_FLOAT *) TOS) = FP_TOS;
\r
64 M_FP_DROP; /* drop FP value */
\r
65 M_DROP; /* drop addr */
\r
68 case ID_FP_FTIMES: /* ( F: r1 r2 -- r1*r2 ) */
\r
69 FP_TOS = M_FP_POP * FP_TOS;
\r
72 case ID_FP_FPLUS: /* ( F: r1 r2 -- r1+r2 ) */
\r
73 FP_TOS = M_FP_POP + FP_TOS;
\r
76 case ID_FP_FMINUS: /* ( F: r1 r2 -- r1-r2 ) */
\r
77 FP_TOS = M_FP_POP - FP_TOS;
\r
80 case ID_FP_FSLASH: /* ( F: r1 r2 -- r1/r2 ) */
\r
81 FP_TOS = M_FP_POP / FP_TOS;
\r
84 case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag ) ( F: r -- ) */
\r
86 TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;
\r
90 case ID_FP_F_ZERO_EQUALS: /* ( -- flag ) ( F: r -- ) */
\r
92 TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;
\r
96 case ID_FP_F_LESS_THAN: /* ( -- flag ) ( F: r1 r2 -- ) */
\r
98 TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;
\r
102 case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */
\r
103 /* printf("f2d = %g\n", FP_TOS); */
\r
108 /* Convert absolute value, then negate D if negative. */
\r
109 PUSH_TOS; /* Save old TOS */
\r
112 ifNeg = (fpTemp < 0.0);
\r
115 fpTemp = 0.0 - fpTemp;
\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
123 fpTemp = fpTemp - fpScratch; /* Remainder */
\r
124 dlo = (ucell_t) fpTemp;
\r
125 /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */
\r
131 /* Push onto stack. */
\r
138 case ID_FP_FFETCH: /* ( addr -- ) ( F: -- r ) */
\r
140 #if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
\r
141 if( IN_CODE_DIC(TOS) )
\r
143 FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );
\r
147 FP_TOS = *((PF_FLOAT *) TOS);
\r
150 FP_TOS = *((PF_FLOAT *) TOS);
\r
155 case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */
\r
157 /* Add 1 to account for FP_TOS in cached in register. */
\r
158 TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);
\r
161 case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */
\r
165 case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */
\r
169 case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */
\r
170 TOS = TOS + sizeof(PF_FLOAT);
\r
173 case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */
\r
174 TOS = TOS * sizeof(PF_FLOAT);
\r
177 case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */
\r
178 FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );
\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
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
191 case ID_FP_FNEGATE:
\r
195 case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */
\r
197 FP_TOS = M_FP_STACK(1);
\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
209 ERR("\nID_FP_FROUND - Not Yet!! FIXME\n");
\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
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
223 case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */
\r
224 FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );
\r
227 case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */
\r
228 FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );
\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
236 case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */
\r
237 FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);
\r
240 case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */
\r
241 FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );
\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
249 case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */
\r
250 FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );
\r
253 case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */
\r
255 FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );
\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
262 case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */
\r
263 FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );
\r
266 case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */
\r
267 FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );
\r
270 #ifndef PF_NO_SHELL
\r
271 case ID_FP_FLITERAL:
\r
272 ffFPLiteral( FP_TOS );
\r
275 #endif /* !PF_NO_SHELL */
\r
277 case ID_FP_FLITERAL_P:
\r
280 /* Some wimpy compilers can't handle this! */
\r
281 FP_TOS = *(((PF_FLOAT *)InsPtr)++);
\r
285 fptr = (PF_FLOAT *)InsPtr;
\r
286 FP_TOS = READ_FLOAT_DIC( fptr++ );
\r
287 InsPtr = (cell_t *) fptr;
\r
292 case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
\r
293 FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
\r
296 case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
\r
297 FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
\r
300 case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
\r
301 FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
\r
304 case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
\r
305 FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
\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
313 case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
\r
314 FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
\r
317 case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
\r
318 FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
\r
321 case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
\r
322 FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
\r
325 case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
\r
326 FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
\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