projects / pforth / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
relicense to 0BSD
[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**
1f99f95d
S		 11** Permission to use, copy, modify, and/or distribute this
12** software for any purpose with or without fee is hereby granted.
13**
14** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
15** WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
16** WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
17** THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
18** CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
19** FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
20** CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
21** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
8e9db35f
PB		 22**
23****************************************************************
24**
25***************************************************************/
26
27#ifdef PF_SUPPORT_FP
28
58a4c23b 29#define FP_DHI1 (((PF_FLOAT)((cell_t)1<<(sizeof(cell_t)*8-2)))*4.0)
8e9db35f
PB		 30
31 case ID_FP_D_TO_F: /* ( dlo dhi -- ) ( F: -- r ) */
32 PUSH_FP_TOS;
33 Scratch = M_POP; /* dlo */
34 DBUG(("dlo = 0x%8x , ", Scratch));
35 DBUG(("dhi = 0x%8x\n", TOS));
36
37 if( ((TOS == 0) && (Scratch >= 0)) ||
38 ((TOS == -1) && (Scratch < 0)))
39 {
40 /* <= 32 bit precision. */
41 FP_TOS = ((PF_FLOAT) Scratch); /* Convert dlo and push on FP stack. */
42 }
43 else /* > 32 bit precision. */
44 {
45 fpTemp = ((PF_FLOAT) TOS); /* dhi */
46 fpTemp *= FP_DHI1;
47 fpScratch = ( (PF_FLOAT) ((ucell_t)Scratch) ); /* Convert TOS and push on FP stack. */
48 FP_TOS = fpTemp + fpScratch;
49 }
50 M_DROP;
51 /* printf("d2f = %g\n", FP_TOS); */
52 break;
53
54 case ID_FP_FSTORE: /* ( addr -- ) ( F: r -- ) */
55#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
56 if( IN_CODE_DIC(TOS) )
57 {
58 WRITE_FLOAT_DIC( (PF_FLOAT *) TOS, FP_TOS );
59 }
60 else
61 {
62 *((PF_FLOAT *) TOS) = FP_TOS;
63 }
64#else
65 *((PF_FLOAT *) TOS) = FP_TOS;
66#endif
67 M_FP_DROP; /* drop FP value */
68 M_DROP; /* drop addr */
69 break;
70
71 case ID_FP_FTIMES: /* ( F: r1 r2 -- r1*r2 ) */
72 FP_TOS = M_FP_POP * FP_TOS;
73 break;
74
75 case ID_FP_FPLUS: /* ( F: r1 r2 -- r1+r2 ) */
76 FP_TOS = M_FP_POP + FP_TOS;
77 break;
78
79 case ID_FP_FMINUS: /* ( F: r1 r2 -- r1-r2 ) */
80 FP_TOS = M_FP_POP - FP_TOS;
81 break;
82
83 case ID_FP_FSLASH: /* ( F: r1 r2 -- r1/r2 ) */
84 FP_TOS = M_FP_POP / FP_TOS;
85 break;
86
87 case ID_FP_F_ZERO_LESS_THAN: /* ( -- flag ) ( F: r -- ) */
88 PUSH_TOS;
89 TOS = (FP_TOS < 0.0) ? FTRUE : FFALSE ;
90 M_FP_DROP;
91 break;
92
93 case ID_FP_F_ZERO_EQUALS: /* ( -- flag ) ( F: r -- ) */
94 PUSH_TOS;
95 TOS = (FP_TOS == 0.0) ? FTRUE : FFALSE ;
96 M_FP_DROP;
97 break;
98
99 case ID_FP_F_LESS_THAN: /* ( -- flag ) ( F: r1 r2 -- ) */
100 PUSH_TOS;
101 TOS = (M_FP_POP < FP_TOS) ? FTRUE : FFALSE ;
102 M_FP_DROP;
103 break;
104
105 case ID_FP_F_TO_D: /* ( -- dlo dhi) ( F: r -- ) */
106 /* printf("f2d = %g\n", FP_TOS); */
107 {
108 ucell_t dlo;
109 cell_t dhi;
110 int ifNeg;
111 /* Convert absolute value, then negate D if negative. */
112 PUSH_TOS; /* Save old TOS */
113 fpTemp = FP_TOS;
114 M_FP_DROP;
115 ifNeg = (fpTemp < 0.0);
116 if( ifNeg )
117 {
118 fpTemp = 0.0 - fpTemp;
119 }
120 fpScratch = fpTemp / FP_DHI1;
121 /* printf("f2d - fpScratch = %g\n", fpScratch); */
122 dhi = (cell_t) fpScratch; /* dhi */
123 fpScratch = ((PF_FLOAT) dhi) * FP_DHI1;
124 /* printf("f2d - , dhi = 0x%x, fpScratch = %g\n", dhi, fpScratch); */
125
126 fpTemp = fpTemp - fpScratch; /* Remainder */
127 dlo = (ucell_t) fpTemp;
128 /* printf("f2d - , dlo = 0x%x, fpTemp = %g\n", dlo, fpTemp); */
129 if( ifNeg )
130 {
131 dlo = 0 - dlo;
132 dhi = 0 - dhi - 1;
133 }
134 /* Push onto stack. */
135 TOS = dlo;
136 PUSH_TOS;
137 TOS = dhi;
138 }
139 break;
140
141 case ID_FP_FFETCH: /* ( addr -- ) ( F: -- r ) */
142 PUSH_FP_TOS;
143#if (defined(PF_BIG_ENDIAN_DIC) || defined(PF_LITTLE_ENDIAN_DIC))
144 if( IN_CODE_DIC(TOS) )
145 {
146 FP_TOS = READ_FLOAT_DIC( (PF_FLOAT *) TOS );
147 }
148 else
149 {
150 FP_TOS = *((PF_FLOAT *) TOS);
151 }
152#else
153 FP_TOS = *((PF_FLOAT *) TOS);
154#endif
155 M_DROP;
156 break;
157
158 case ID_FP_FDEPTH: /* ( -- n ) ( F: -- ) */
159 PUSH_TOS;
160 /* Add 1 to account for FP_TOS in cached in register. */
161 TOS = (( M_FP_SPZERO - FP_STKPTR) + 1);
162 break;
163
164 case ID_FP_FDROP: /* ( -- ) ( F: r -- ) */
165 M_FP_DROP;
166 break;
167
168 case ID_FP_FDUP: /* ( -- ) ( F: r -- r r ) */
169 PUSH_FP_TOS;
170 break;
171
172 case ID_FP_FLOAT_PLUS: /* ( addr1 -- addr2 ) ( F: -- ) */
173 TOS = TOS + sizeof(PF_FLOAT);
174 break;
175
176 case ID_FP_FLOATS: /* ( n -- size ) ( F: -- ) */
177 TOS = TOS * sizeof(PF_FLOAT);
178 break;
179
180 case ID_FP_FLOOR: /* ( -- ) ( F: r1 -- r2 ) */
181 FP_TOS = (PF_FLOAT) fp_floor( FP_TOS );
182 break;
183
184 case ID_FP_FMAX: /* ( -- ) ( F: r1 r2 -- r3 ) */
185 fpScratch = M_FP_POP;
186 FP_TOS = ( FP_TOS > fpScratch ) ? FP_TOS : fpScratch ;
187 break;
188
189 case ID_FP_FMIN: /* ( -- ) ( F: r1 r2 -- r3 ) */
190 fpScratch = M_FP_POP;
191 FP_TOS = ( FP_TOS < fpScratch ) ? FP_TOS : fpScratch ;
192 break;
193
194 case ID_FP_FNEGATE:
195 FP_TOS = -FP_TOS;
196 break;
197
198 case ID_FP_FOVER: /* ( -- ) ( F: r1 r2 -- r1 r2 r1 ) */
199 PUSH_FP_TOS;
200 FP_TOS = M_FP_STACK(1);
201 break;
202
203 case ID_FP_FROT: /* ( -- ) ( F: r1 r2 r3 -- r2 r3 r1 ) */
204 fpScratch = M_FP_POP; /* r2 */
205 fpTemp = M_FP_POP; /* r1 */
206 M_FP_PUSH( fpScratch ); /* r2 */
207 PUSH_FP_TOS; /* r3 */
208 FP_TOS = fpTemp; /* r1 */
209 break;
210
211 case ID_FP_FROUND:
3a940535 212 PUSH_TOS;
65279741 213 TOS = (cell_t)fp_round(FP_TOS);
3a940535 214 M_FP_DROP;
8e9db35f
PB		 215 break;
216
217 case ID_FP_FSWAP: /* ( -- ) ( F: r1 r2 -- r2 r1 ) */
218 fpScratch = FP_TOS;
219 FP_TOS = *FP_STKPTR;
220 *FP_STKPTR = fpScratch;
221 break;
222
223 case ID_FP_FSTAR_STAR: /* ( -- ) ( F: r1 r2 -- r1^r2 ) */
224 fpScratch = M_FP_POP;
225 FP_TOS = (PF_FLOAT) fp_pow(fpScratch, FP_TOS);
226 break;
227
228 case ID_FP_FABS: /* ( -- ) ( F: r1 -- r2 ) */
229 FP_TOS = (PF_FLOAT) fp_fabs( FP_TOS );
230 break;
231
232 case ID_FP_FACOS: /* ( -- ) ( F: r1 -- r2 ) */
233 FP_TOS = (PF_FLOAT) fp_acos( FP_TOS );
234 break;
235
236 case ID_FP_FACOSH: /* ( -- ) ( F: r1 -- r2 ) */
237 /* fp_acosh(x) = fp_log(y + sqrt(y^2 - 1) */
238 FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) - 1)));
239 break;
240
241 case ID_FP_FALOG: /* ( -- ) ( F: r1 -- r2 ) */
242 FP_TOS = (PF_FLOAT) fp_pow(10.0,FP_TOS);
243 break;
244
245 case ID_FP_FASIN: /* ( -- ) ( F: r1 -- r2 ) */
246 FP_TOS = (PF_FLOAT) fp_asin( FP_TOS );
247 break;
248
249 case ID_FP_FASINH: /* ( -- ) ( F: r1 -- r2 ) */
250 /* asinh(x) = fp_log(y + fp_sqrt(y^2 + 1) */
251 FP_TOS = (PF_FLOAT) fp_log(FP_TOS + (fp_sqrt((FP_TOS * FP_TOS) + 1)));
252 break;
253
254 case ID_FP_FATAN: /* ( -- ) ( F: r1 -- r2 ) */
255 FP_TOS = (PF_FLOAT) fp_atan( FP_TOS );
256 break;
257
258 case ID_FP_FATAN2: /* ( -- ) ( F: r1 r2 -- atan(r1/r2) ) */
259 fpTemp = M_FP_POP;
260 FP_TOS = (PF_FLOAT) fp_atan2( fpTemp, FP_TOS );
261 break;
262
263 case ID_FP_FATANH: /* ( -- ) ( F: r1 -- r2 ) */
264 FP_TOS = (PF_FLOAT) (0.5 * fp_log((1 + FP_TOS) / (1 - FP_TOS)));
265 break;
266
267 case ID_FP_FCOS: /* ( -- ) ( F: r1 -- r2 ) */
268 FP_TOS = (PF_FLOAT) fp_cos( FP_TOS );
269 break;
270
271 case ID_FP_FCOSH: /* ( -- ) ( F: r1 -- r2 ) */
272 FP_TOS = (PF_FLOAT) fp_cosh( FP_TOS );
273 break;
274
275#ifndef PF_NO_SHELL
276 case ID_FP_FLITERAL:
277 ffFPLiteral( FP_TOS );
278 M_FP_DROP;
279 endcase;
280#endif /* !PF_NO_SHELL */
281
282 case ID_FP_FLITERAL_P:
283 PUSH_FP_TOS;
284#if 0
285/* Some wimpy compilers can't handle this! */
286 FP_TOS = *(((PF_FLOAT *)InsPtr)++);
287#else
288 {
289 PF_FLOAT *fptr;
290 fptr = (PF_FLOAT *)InsPtr;
291 FP_TOS = READ_FLOAT_DIC( fptr++ );
292 InsPtr = (cell_t *) fptr;
293 }
294#endif
295 endcase;
296
297 case ID_FP_FLN: /* ( -- ) ( F: r1 -- r2 ) */
298 FP_TOS = (PF_FLOAT) fp_log(FP_TOS);
299 break;
300
301 case ID_FP_FLNP1: /* ( -- ) ( F: r1 -- r2 ) */
302 FP_TOS = (PF_FLOAT) (fp_log(FP_TOS) + 1.0);
303 break;
304
305 case ID_FP_FLOG: /* ( -- ) ( F: r1 -- r2 ) */
306 FP_TOS = (PF_FLOAT) fp_log10( FP_TOS );
307 break;
308
309 case ID_FP_FSIN: /* ( -- ) ( F: r1 -- r2 ) */
310 FP_TOS = (PF_FLOAT) fp_sin( FP_TOS );
311 break;
312
313 case ID_FP_FSINCOS: /* ( -- ) ( F: r1 -- r2 r3 ) */
314 M_FP_PUSH((PF_FLOAT) fp_sin(FP_TOS));
315 FP_TOS = (PF_FLOAT) fp_cos(FP_TOS);
316 break;
317
318 case ID_FP_FSINH: /* ( -- ) ( F: r1 -- r2 ) */
319 FP_TOS = (PF_FLOAT) fp_sinh( FP_TOS );
320 break;
321
322 case ID_FP_FSQRT: /* ( -- ) ( F: r1 -- r2 ) */
323 FP_TOS = (PF_FLOAT) fp_sqrt( FP_TOS );
324 break;
325
326 case ID_FP_FTAN: /* ( -- ) ( F: r1 -- r2 ) */
327 FP_TOS = (PF_FLOAT) fp_tan( FP_TOS );
328 break;
329
330 case ID_FP_FTANH: /* ( -- ) ( F: r1 -- r2 ) */
331 FP_TOS = (PF_FLOAT) fp_tanh( FP_TOS );
332 break;
333
334 case ID_FP_FPICK: /* ( n -- ) ( F: -- f[n] ) */
335 PUSH_FP_TOS; /* push cached floats into RAM */
336 FP_TOS = FP_STKPTR[TOS]; /* 0 FPICK gets top of FP stack */
337 M_DROP;
338 break;
339
340
341#endif
Fork of 'github/philburk/pforth', a portable ANS-like Forth written in ANSI C.