projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
V25 with 64-bit support
[pforth] / csrc / pfinnrfp.h
CommitLineData
bb6b2dcd 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
1cb310e6 44 fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) ); /* Convert TOS and push on FP stack. */\r
bb6b2dcd 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
1cb310e6 105 ucell_t dlo;\r
106 cell_t dhi;\r
bb6b2dcd 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
1cb310e6 119 dhi = (cell_t) fpScratch; /* dhi */\r
bb6b2dcd 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
1cb310e6 124 dlo = (ucell_t) fpTemp;\r
bb6b2dcd 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
1cb310e6 287 InsPtr = (cell_t *) fptr;\r
bb6b2dcd 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
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.