projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
The MSVC x86_64 compiler defines long as 32-bits.
[pforth] / csrc / pfinnrfp.h
CommitLineData
8e9db35f
PB		 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
58a4c23b 26#define FP_DHI1 (((PF_FLOAT)((cell_t)1<<(sizeof(cell_t)*8-2)))*4.0)
8e9db35f
PB		 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:
3a940535 209 PUSH_TOS;
65279741 210 TOS = (cell_t)fp_round(FP_TOS);
3a940535 211 M_FP_DROP;
8e9db35f
PB		 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
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.