1 /*******************************************************************
2 ** f l o a t . c
3 ** Forth Inspired Command Language
4 ** ANS Forth FLOAT word-set written in C
5 ** Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu)
6 ** Created: Apr 2001
7 ** $Id: float.c,v 1.8 2001/12/05 07:21:34 jsadler Exp $
8 *******************************************************************/
9 /*
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
12 **
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
14 **
15 ** I am interested in hearing from anyone who uses ficl. If you have
16 ** a problem, a success story, a defect, an enhancement request, or
17 ** if you would like to contribute to the ficl release, please
18 ** contact me by email at the address above.
19 **
20 ** L I C E N S E and D I S C L A I M E R
21 **
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
24 ** are met:
25 ** 1. Redistributions of source code must retain the above copyright
26 ** notice, this list of conditions and the following disclaimer.
27 ** 2. Redistributions in binary form must reproduce the above copyright
28 ** notice, this list of conditions and the following disclaimer in the
29 ** documentation and/or other materials provided with the distribution.
30 **
31 ** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
32 ** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
33 ** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
34 ** ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
35 ** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
36 ** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
37 ** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
38 ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
39 ** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
40 ** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
41 ** SUCH DAMAGE.
42 */
43
44
45 #include "ficl.h"
46
47 #if FICL_WANT_FLOAT
48 #include <stdlib.h>
49 #include <stdio.h>
50 #include <string.h>
51 #include <ctype.h>
52 #include <math.h>
53
54 /*******************************************************************
55 ** Do float addition r1 + r2.
56 ** f+ ( r1 r2 -- r )
57 *******************************************************************/
Fadd(FICL_VM * pVM)58 static void Fadd(FICL_VM *pVM)
59 {
60 FICL_FLOAT f;
61
62 #if FICL_ROBUST > 1
63 vmCheckFStack(pVM, 2, 1);
64 #endif
65
66 f = POPFLOAT();
67 f += GETTOPF().f;
68 SETTOPF(f);
69 }
70
71 /*******************************************************************
72 ** Do float subtraction r1 - r2.
73 ** f- ( r1 r2 -- r )
74 *******************************************************************/
Fsub(FICL_VM * pVM)75 static void Fsub(FICL_VM *pVM)
76 {
77 FICL_FLOAT f;
78
79 #if FICL_ROBUST > 1
80 vmCheckFStack(pVM, 2, 1);
81 #endif
82
83 f = POPFLOAT();
84 f = GETTOPF().f - f;
85 SETTOPF(f);
86 }
87
88 /*******************************************************************
89 ** Do float multiplication r1 * r2.
90 ** f* ( r1 r2 -- r )
91 *******************************************************************/
Fmul(FICL_VM * pVM)92 static void Fmul(FICL_VM *pVM)
93 {
94 FICL_FLOAT f;
95
96 #if FICL_ROBUST > 1
97 vmCheckFStack(pVM, 2, 1);
98 #endif
99
100 f = POPFLOAT();
101 f *= GETTOPF().f;
102 SETTOPF(f);
103 }
104
105 /*******************************************************************
106 ** Do float negation.
107 ** fnegate ( r -- r )
108 *******************************************************************/
Fnegate(FICL_VM * pVM)109 static void Fnegate(FICL_VM *pVM)
110 {
111 FICL_FLOAT f;
112
113 #if FICL_ROBUST > 1
114 vmCheckFStack(pVM, 1, 1);
115 #endif
116
117 f = -GETTOPF().f;
118 SETTOPF(f);
119 }
120
121 /*******************************************************************
122 ** Do float division r1 / r2.
123 ** f/ ( r1 r2 -- r )
124 *******************************************************************/
Fdiv(FICL_VM * pVM)125 static void Fdiv(FICL_VM *pVM)
126 {
127 FICL_FLOAT f;
128
129 #if FICL_ROBUST > 1
130 vmCheckFStack(pVM, 2, 1);
131 #endif
132
133 f = POPFLOAT();
134 f = GETTOPF().f / f;
135 SETTOPF(f);
136 }
137
138 /*******************************************************************
139 ** Do float + integer r + n.
140 ** f+i ( r n -- r )
141 *******************************************************************/
Faddi(FICL_VM * pVM)142 static void Faddi(FICL_VM *pVM)
143 {
144 FICL_FLOAT f;
145
146 #if FICL_ROBUST > 1
147 vmCheckFStack(pVM, 1, 1);
148 vmCheckStack(pVM, 1, 0);
149 #endif
150
151 f = (FICL_FLOAT)POPINT();
152 f += GETTOPF().f;
153 SETTOPF(f);
154 }
155
156 /*******************************************************************
157 ** Do float - integer r - n.
158 ** f-i ( r n -- r )
159 *******************************************************************/
Fsubi(FICL_VM * pVM)160 static void Fsubi(FICL_VM *pVM)
161 {
162 FICL_FLOAT f;
163
164 #if FICL_ROBUST > 1
165 vmCheckFStack(pVM, 1, 1);
166 vmCheckStack(pVM, 1, 0);
167 #endif
168
169 f = GETTOPF().f;
170 f -= (FICL_FLOAT)POPINT();
171 SETTOPF(f);
172 }
173
174 /*******************************************************************
175 ** Do float * integer r * n.
176 ** f*i ( r n -- r )
177 *******************************************************************/
Fmuli(FICL_VM * pVM)178 static void Fmuli(FICL_VM *pVM)
179 {
180 FICL_FLOAT f;
181
182 #if FICL_ROBUST > 1
183 vmCheckFStack(pVM, 1, 1);
184 vmCheckStack(pVM, 1, 0);
185 #endif
186
187 f = (FICL_FLOAT)POPINT();
188 f *= GETTOPF().f;
189 SETTOPF(f);
190 }
191
192 /*******************************************************************
193 ** Do float / integer r / n.
194 ** f/i ( r n -- r )
195 *******************************************************************/
Fdivi(FICL_VM * pVM)196 static void Fdivi(FICL_VM *pVM)
197 {
198 FICL_FLOAT f;
199
200 #if FICL_ROBUST > 1
201 vmCheckFStack(pVM, 1, 1);
202 vmCheckStack(pVM, 1, 0);
203 #endif
204
205 f = GETTOPF().f;
206 f /= (FICL_FLOAT)POPINT();
207 SETTOPF(f);
208 }
209
210 /*******************************************************************
211 ** Do integer - float n - r.
212 ** i-f ( n r -- r )
213 *******************************************************************/
isubf(FICL_VM * pVM)214 static void isubf(FICL_VM *pVM)
215 {
216 FICL_FLOAT f;
217
218 #if FICL_ROBUST > 1
219 vmCheckFStack(pVM, 1, 1);
220 vmCheckStack(pVM, 1, 0);
221 #endif
222
223 f = (FICL_FLOAT)POPINT();
224 f -= GETTOPF().f;
225 SETTOPF(f);
226 }
227
228 /*******************************************************************
229 ** Do integer / float n / r.
230 ** i/f ( n r -- r )
231 *******************************************************************/
idivf(FICL_VM * pVM)232 static void idivf(FICL_VM *pVM)
233 {
234 FICL_FLOAT f;
235
236 #if FICL_ROBUST > 1
237 vmCheckFStack(pVM, 1,1);
238 vmCheckStack(pVM, 1, 0);
239 #endif
240
241 f = (FICL_FLOAT)POPINT();
242 f /= GETTOPF().f;
243 SETTOPF(f);
244 }
245
246 /*******************************************************************
247 ** Do integer to float conversion.
248 ** int>float ( n -- r )
249 *******************************************************************/
itof(FICL_VM * pVM)250 static void itof(FICL_VM *pVM)
251 {
252 float f;
253
254 #if FICL_ROBUST > 1
255 vmCheckStack(pVM, 1, 0);
256 vmCheckFStack(pVM, 0, 1);
257 #endif
258
259 f = (float)POPINT();
260 PUSHFLOAT(f);
261 }
262
263 /*******************************************************************
264 ** Do float to integer conversion.
265 ** float>int ( r -- n )
266 *******************************************************************/
Ftoi(FICL_VM * pVM)267 static void Ftoi(FICL_VM *pVM)
268 {
269 FICL_INT i;
270
271 #if FICL_ROBUST > 1
272 vmCheckStack(pVM, 0, 1);
273 vmCheckFStack(pVM, 1, 0);
274 #endif
275
276 i = (FICL_INT)POPFLOAT();
277 PUSHINT(i);
278 }
279
280 /*******************************************************************
281 ** Floating point constant execution word.
282 *******************************************************************/
FconstantParen(FICL_VM * pVM)283 void FconstantParen(FICL_VM *pVM)
284 {
285 FICL_WORD *pFW = pVM->runningWord;
286
287 #if FICL_ROBUST > 1
288 vmCheckFStack(pVM, 0, 1);
289 #endif
290
291 PUSHFLOAT(pFW->param[0].f);
292 }
293
294 /*******************************************************************
295 ** Create a floating point constant.
296 ** fconstant ( r -"name"- )
297 *******************************************************************/
Fconstant(FICL_VM * pVM)298 static void Fconstant(FICL_VM *pVM)
299 {
300 FICL_DICT *dp = vmGetDict(pVM);
301 STRINGINFO si = vmGetWord(pVM);
302
303 #if FICL_ROBUST > 1
304 vmCheckFStack(pVM, 1, 0);
305 #endif
306
307 dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT);
308 dictAppendCell(dp, stackPop(pVM->fStack));
309 }
310
311 /*******************************************************************
312 ** Display a float in decimal format.
313 ** f. ( r -- )
314 *******************************************************************/
FDot(FICL_VM * pVM)315 static void FDot(FICL_VM *pVM)
316 {
317 float f;
318
319 #if FICL_ROBUST > 1
320 vmCheckFStack(pVM, 1, 0);
321 #endif
322
323 f = POPFLOAT();
324 sprintf(pVM->pad,"%#f ",f);
325 vmTextOut(pVM, pVM->pad, 0);
326 }
327
328 /*******************************************************************
329 ** Display a float in engineering format.
330 ** fe. ( r -- )
331 *******************************************************************/
EDot(FICL_VM * pVM)332 static void EDot(FICL_VM *pVM)
333 {
334 float f;
335
336 #if FICL_ROBUST > 1
337 vmCheckFStack(pVM, 1, 0);
338 #endif
339
340 f = POPFLOAT();
341 sprintf(pVM->pad,"%#e ",f);
342 vmTextOut(pVM, pVM->pad, 0);
343 }
344
345 /**************************************************************************
346 d i s p l a y FS t a c k
347 ** Display the parameter stack (code for "f.s")
348 ** f.s ( -- )
349 **************************************************************************/
displayFStack(FICL_VM * pVM)350 static void displayFStack(FICL_VM *pVM)
351 {
352 int d = stackDepth(pVM->fStack);
353 int i;
354 CELL *pCell;
355
356 vmCheckFStack(pVM, 0, 0);
357
358 vmTextOut(pVM, "F:", 0);
359
360 if (d == 0)
361 vmTextOut(pVM, "[0]", 0);
362 else
363 {
364 ltoa(d, &pVM->pad[1], pVM->base);
365 pVM->pad[0] = '[';
366 strcat(pVM->pad,"] ");
367 vmTextOut(pVM,pVM->pad,0);
368
369 pCell = pVM->fStack->sp - d;
370 for (i = 0; i < d; i++)
371 {
372 sprintf(pVM->pad,"%#f ",(*pCell++).f);
373 vmTextOut(pVM,pVM->pad,0);
374 }
375 }
376 }
377
378 /*******************************************************************
379 ** Do float stack depth.
380 ** fdepth ( -- n )
381 *******************************************************************/
Fdepth(FICL_VM * pVM)382 static void Fdepth(FICL_VM *pVM)
383 {
384 int i;
385
386 #if FICL_ROBUST > 1
387 vmCheckStack(pVM, 0, 1);
388 #endif
389
390 i = stackDepth(pVM->fStack);
391 PUSHINT(i);
392 }
393
394 /*******************************************************************
395 ** Do float stack drop.
396 ** fdrop ( r -- )
397 *******************************************************************/
Fdrop(FICL_VM * pVM)398 static void Fdrop(FICL_VM *pVM)
399 {
400 #if FICL_ROBUST > 1
401 vmCheckFStack(pVM, 1, 0);
402 #endif
403
404 DROPF(1);
405 }
406
407 /*******************************************************************
408 ** Do float stack 2drop.
409 ** f2drop ( r r -- )
410 *******************************************************************/
FtwoDrop(FICL_VM * pVM)411 static void FtwoDrop(FICL_VM *pVM)
412 {
413 #if FICL_ROBUST > 1
414 vmCheckFStack(pVM, 2, 0);
415 #endif
416
417 DROPF(2);
418 }
419
420 /*******************************************************************
421 ** Do float stack dup.
422 ** fdup ( r -- r r )
423 *******************************************************************/
Fdup(FICL_VM * pVM)424 static void Fdup(FICL_VM *pVM)
425 {
426 #if FICL_ROBUST > 1
427 vmCheckFStack(pVM, 1, 2);
428 #endif
429
430 PICKF(0);
431 }
432
433 /*******************************************************************
434 ** Do float stack 2dup.
435 ** f2dup ( r1 r2 -- r1 r2 r1 r2 )
436 *******************************************************************/
FtwoDup(FICL_VM * pVM)437 static void FtwoDup(FICL_VM *pVM)
438 {
439 #if FICL_ROBUST > 1
440 vmCheckFStack(pVM, 2, 4);
441 #endif
442
443 PICKF(1);
444 PICKF(1);
445 }
446
447 /*******************************************************************
448 ** Do float stack over.
449 ** fover ( r1 r2 -- r1 r2 r1 )
450 *******************************************************************/
Fover(FICL_VM * pVM)451 static void Fover(FICL_VM *pVM)
452 {
453 #if FICL_ROBUST > 1
454 vmCheckFStack(pVM, 2, 3);
455 #endif
456
457 PICKF(1);
458 }
459
460 /*******************************************************************
461 ** Do float stack 2over.
462 ** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
463 *******************************************************************/
FtwoOver(FICL_VM * pVM)464 static void FtwoOver(FICL_VM *pVM)
465 {
466 #if FICL_ROBUST > 1
467 vmCheckFStack(pVM, 4, 6);
468 #endif
469
470 PICKF(3);
471 PICKF(3);
472 }
473
474 /*******************************************************************
475 ** Do float stack pick.
476 ** fpick ( n -- r )
477 *******************************************************************/
Fpick(FICL_VM * pVM)478 static void Fpick(FICL_VM *pVM)
479 {
480 CELL c = POP();
481
482 #if FICL_ROBUST > 1
483 vmCheckFStack(pVM, c.i+1, c.i+2);
484 #endif
485
486 PICKF(c.i);
487 }
488
489 /*******************************************************************
490 ** Do float stack ?dup.
491 ** f?dup ( r -- r )
492 *******************************************************************/
FquestionDup(FICL_VM * pVM)493 static void FquestionDup(FICL_VM *pVM)
494 {
495 CELL c;
496
497 #if FICL_ROBUST > 1
498 vmCheckFStack(pVM, 1, 2);
499 #endif
500
501 c = GETTOPF();
502 if (c.f != 0)
503 PICKF(0);
504 }
505
506 /*******************************************************************
507 ** Do float stack roll.
508 ** froll ( n -- )
509 *******************************************************************/
Froll(FICL_VM * pVM)510 static void Froll(FICL_VM *pVM)
511 {
512 int i = POP().i;
513 i = (i > 0) ? i : 0;
514
515 #if FICL_ROBUST > 1
516 vmCheckFStack(pVM, i+1, i+1);
517 #endif
518
519 ROLLF(i);
520 }
521
522 /*******************************************************************
523 ** Do float stack -roll.
524 ** f-roll ( n -- )
525 *******************************************************************/
FminusRoll(FICL_VM * pVM)526 static void FminusRoll(FICL_VM *pVM)
527 {
528 int i = POP().i;
529 i = (i > 0) ? i : 0;
530
531 #if FICL_ROBUST > 1
532 vmCheckFStack(pVM, i+1, i+1);
533 #endif
534
535 ROLLF(-i);
536 }
537
538 /*******************************************************************
539 ** Do float stack rot.
540 ** frot ( r1 r2 r3 -- r2 r3 r1 )
541 *******************************************************************/
Frot(FICL_VM * pVM)542 static void Frot(FICL_VM *pVM)
543 {
544 #if FICL_ROBUST > 1
545 vmCheckFStack(pVM, 3, 3);
546 #endif
547
548 ROLLF(2);
549 }
550
551 /*******************************************************************
552 ** Do float stack -rot.
553 ** f-rot ( r1 r2 r3 -- r3 r1 r2 )
554 *******************************************************************/
Fminusrot(FICL_VM * pVM)555 static void Fminusrot(FICL_VM *pVM)
556 {
557 #if FICL_ROBUST > 1
558 vmCheckFStack(pVM, 3, 3);
559 #endif
560
561 ROLLF(-2);
562 }
563
564 /*******************************************************************
565 ** Do float stack swap.
566 ** fswap ( r1 r2 -- r2 r1 )
567 *******************************************************************/
Fswap(FICL_VM * pVM)568 static void Fswap(FICL_VM *pVM)
569 {
570 #if FICL_ROBUST > 1
571 vmCheckFStack(pVM, 2, 2);
572 #endif
573
574 ROLLF(1);
575 }
576
577 /*******************************************************************
578 ** Do float stack 2swap
579 ** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
580 *******************************************************************/
FtwoSwap(FICL_VM * pVM)581 static void FtwoSwap(FICL_VM *pVM)
582 {
583 #if FICL_ROBUST > 1
584 vmCheckFStack(pVM, 4, 4);
585 #endif
586
587 ROLLF(3);
588 ROLLF(3);
589 }
590
591 /*******************************************************************
592 ** Get a floating point number from a variable.
593 ** f@ ( n -- r )
594 *******************************************************************/
Ffetch(FICL_VM * pVM)595 static void Ffetch(FICL_VM *pVM)
596 {
597 CELL *pCell;
598
599 #if FICL_ROBUST > 1
600 vmCheckFStack(pVM, 0, 1);
601 vmCheckStack(pVM, 1, 0);
602 #endif
603
604 pCell = (CELL *)POPPTR();
605 PUSHFLOAT(pCell->f);
606 }
607
608 /*******************************************************************
609 ** Store a floating point number into a variable.
610 ** f! ( r n -- )
611 *******************************************************************/
Fstore(FICL_VM * pVM)612 static void Fstore(FICL_VM *pVM)
613 {
614 CELL *pCell;
615
616 #if FICL_ROBUST > 1
617 vmCheckFStack(pVM, 1, 0);
618 vmCheckStack(pVM, 1, 0);
619 #endif
620
621 pCell = (CELL *)POPPTR();
622 pCell->f = POPFLOAT();
623 }
624
625 /*******************************************************************
626 ** Add a floating point number to contents of a variable.
627 ** f+! ( r n -- )
628 *******************************************************************/
FplusStore(FICL_VM * pVM)629 static void FplusStore(FICL_VM *pVM)
630 {
631 CELL *pCell;
632
633 #if FICL_ROBUST > 1
634 vmCheckStack(pVM, 1, 0);
635 vmCheckFStack(pVM, 1, 0);
636 #endif
637
638 pCell = (CELL *)POPPTR();
639 pCell->f += POPFLOAT();
640 }
641
642 /*******************************************************************
643 ** Floating point literal execution word.
644 *******************************************************************/
fliteralParen(FICL_VM * pVM)645 static void fliteralParen(FICL_VM *pVM)
646 {
647 #if FICL_ROBUST > 1
648 vmCheckStack(pVM, 0, 1);
649 #endif
650
651 PUSHFLOAT(*(float*)(pVM->ip));
652 vmBranchRelative(pVM, 1);
653 }
654
655 /*******************************************************************
656 ** Compile a floating point literal.
657 *******************************************************************/
fliteralIm(FICL_VM * pVM)658 static void fliteralIm(FICL_VM *pVM)
659 {
660 FICL_DICT *dp = vmGetDict(pVM);
661 FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)");
662
663 #if FICL_ROBUST > 1
664 vmCheckFStack(pVM, 1, 0);
665 #endif
666
667 dictAppendCell(dp, LVALUEtoCELL(pfLitParen));
668 dictAppendCell(dp, stackPop(pVM->fStack));
669 }
670
671 /*******************************************************************
672 ** Do float 0= comparison r = 0.0.
673 ** f0= ( r -- T/F )
674 *******************************************************************/
FzeroEquals(FICL_VM * pVM)675 static void FzeroEquals(FICL_VM *pVM)
676 {
677 CELL c;
678
679 #if FICL_ROBUST > 1
680 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
681 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
682 #endif
683
684 c.i = FICL_BOOL(POPFLOAT() == 0);
685 PUSH(c);
686 }
687
688 /*******************************************************************
689 ** Do float 0< comparison r < 0.0.
690 ** f0< ( r -- T/F )
691 *******************************************************************/
FzeroLess(FICL_VM * pVM)692 static void FzeroLess(FICL_VM *pVM)
693 {
694 CELL c;
695
696 #if FICL_ROBUST > 1
697 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
698 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
699 #endif
700
701 c.i = FICL_BOOL(POPFLOAT() < 0);
702 PUSH(c);
703 }
704
705 /*******************************************************************
706 ** Do float 0> comparison r > 0.0.
707 ** f0> ( r -- T/F )
708 *******************************************************************/
FzeroGreater(FICL_VM * pVM)709 static void FzeroGreater(FICL_VM *pVM)
710 {
711 CELL c;
712
713 #if FICL_ROBUST > 1
714 vmCheckFStack(pVM, 1, 0);
715 vmCheckStack(pVM, 0, 1);
716 #endif
717
718 c.i = FICL_BOOL(POPFLOAT() > 0);
719 PUSH(c);
720 }
721
722 /*******************************************************************
723 ** Do float = comparison r1 = r2.
724 ** f= ( r1 r2 -- T/F )
725 *******************************************************************/
FisEqual(FICL_VM * pVM)726 static void FisEqual(FICL_VM *pVM)
727 {
728 float x, y;
729
730 #if FICL_ROBUST > 1
731 vmCheckFStack(pVM, 2, 0);
732 vmCheckStack(pVM, 0, 1);
733 #endif
734
735 x = POPFLOAT();
736 y = POPFLOAT();
737 PUSHINT(FICL_BOOL(x == y));
738 }
739
740 /*******************************************************************
741 ** Do float < comparison r1 < r2.
742 ** f< ( r1 r2 -- T/F )
743 *******************************************************************/
FisLess(FICL_VM * pVM)744 static void FisLess(FICL_VM *pVM)
745 {
746 float x, y;
747
748 #if FICL_ROBUST > 1
749 vmCheckFStack(pVM, 2, 0);
750 vmCheckStack(pVM, 0, 1);
751 #endif
752
753 y = POPFLOAT();
754 x = POPFLOAT();
755 PUSHINT(FICL_BOOL(x < y));
756 }
757
758 /*******************************************************************
759 ** Do float > comparison r1 > r2.
760 ** f> ( r1 r2 -- T/F )
761 *******************************************************************/
FisGreater(FICL_VM * pVM)762 static void FisGreater(FICL_VM *pVM)
763 {
764 float x, y;
765
766 #if FICL_ROBUST > 1
767 vmCheckFStack(pVM, 2, 0);
768 vmCheckStack(pVM, 0, 1);
769 #endif
770
771 y = POPFLOAT();
772 x = POPFLOAT();
773 PUSHINT(FICL_BOOL(x > y));
774 }
775
776
777 /*******************************************************************
778 ** Move float to param stack (assumes they both fit in a single CELL)
779 ** f>s
780 *******************************************************************/
FFrom(FICL_VM * pVM)781 static void FFrom(FICL_VM *pVM)
782 {
783 CELL c;
784
785 #if FICL_ROBUST > 1
786 vmCheckFStack(pVM, 1, 0);
787 vmCheckStack(pVM, 0, 1);
788 #endif
789
790 c = stackPop(pVM->fStack);
791 stackPush(pVM->pStack, c);
792 return;
793 }
794
ToF(FICL_VM * pVM)795 static void ToF(FICL_VM *pVM)
796 {
797 CELL c;
798
799 #if FICL_ROBUST > 1
800 vmCheckFStack(pVM, 0, 1);
801 vmCheckStack(pVM, 1, 0);
802 #endif
803
804 c = stackPop(pVM->pStack);
805 stackPush(pVM->fStack, c);
806 return;
807 }
808
809
810 /**************************************************************************
811 F l o a t P a r s e S t a t e
812 ** Enum to determine the current segment of a floating point number
813 ** being parsed.
814 **************************************************************************/
815 #define NUMISNEG 1
816 #define EXPISNEG 2
817
818 typedef enum _floatParseState
819 {
820 FPS_START,
821 FPS_ININT,
822 FPS_INMANT,
823 FPS_STARTEXP,
824 FPS_INEXP
825 } FloatParseState;
826
827 /**************************************************************************
828 f i c l P a r s e F l o a t N u m b e r
829 ** pVM -- Virtual Machine pointer.
830 ** si -- String to parse.
831 ** Returns 1 if successful, 0 if not.
832 **************************************************************************/
ficlParseFloatNumber(FICL_VM * pVM,STRINGINFO si)833 int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
834 {
835 unsigned char ch, digit;
836 char *cp;
837 FICL_COUNT count;
838 float power;
839 float accum = 0.0f;
840 float mant = 0.1f;
841 FICL_INT exponent = 0;
842 char flag = 0;
843 FloatParseState estate = FPS_START;
844
845 #if FICL_ROBUST > 1
846 vmCheckFStack(pVM, 0, 1);
847 #endif
848
849 /*
850 ** floating point numbers only allowed in base 10
851 */
852 if (pVM->base != 10)
853 return(0);
854
855
856 cp = SI_PTR(si);
857 count = (FICL_COUNT)SI_COUNT(si);
858
859 /* Loop through the string's characters. */
860 while ((count--) && ((ch = *cp++) != 0))
861 {
862 switch (estate)
863 {
864 /* At start of the number so look for a sign. */
865 case FPS_START:
866 {
867 estate = FPS_ININT;
868 if (ch == '-')
869 {
870 flag |= NUMISNEG;
871 break;
872 }
873 if (ch == '+')
874 {
875 break;
876 }
877 } /* Note! Drop through to FPS_ININT */
878 /*
879 **Converting integer part of number.
880 ** Only allow digits, decimal and 'E'.
881 */
882 case FPS_ININT:
883 {
884 if (ch == '.')
885 {
886 estate = FPS_INMANT;
887 }
888 else if ((ch == 'e') || (ch == 'E'))
889 {
890 estate = FPS_STARTEXP;
891 }
892 else
893 {
894 digit = (unsigned char)(ch - '0');
895 if (digit > 9)
896 return(0);
897
898 accum = accum * 10 + digit;
899
900 }
901 break;
902 }
903 /*
904 ** Processing the fraction part of number.
905 ** Only allow digits and 'E'
906 */
907 case FPS_INMANT:
908 {
909 if ((ch == 'e') || (ch == 'E'))
910 {
911 estate = FPS_STARTEXP;
912 }
913 else
914 {
915 digit = (unsigned char)(ch - '0');
916 if (digit > 9)
917 return(0);
918
919 accum += digit * mant;
920 mant *= 0.1f;
921 }
922 break;
923 }
924 /* Start processing the exponent part of number. */
925 /* Look for sign. */
926 case FPS_STARTEXP:
927 {
928 estate = FPS_INEXP;
929
930 if (ch == '-')
931 {
932 flag |= EXPISNEG;
933 break;
934 }
935 else if (ch == '+')
936 {
937 break;
938 }
939 } /* Note! Drop through to FPS_INEXP */
940 /*
941 ** Processing the exponent part of number.
942 ** Only allow digits.
943 */
944 case FPS_INEXP:
945 {
946 digit = (unsigned char)(ch - '0');
947 if (digit > 9)
948 return(0);
949
950 exponent = exponent * 10 + digit;
951
952 break;
953 }
954 }
955 }
956
957 /* If parser never made it to the exponent this is not a float. */
958 if (estate < FPS_STARTEXP)
959 return(0);
960
961 /* Set the sign of the number. */
962 if (flag & NUMISNEG)
963 accum = -accum;
964
965 /* If exponent is not 0 then adjust number by it. */
966 if (exponent != 0)
967 {
968 /* Determine if exponent is negative. */
969 if (flag & EXPISNEG)
970 {
971 exponent = -exponent;
972 }
973 /* power = 10^x */
974 power = (float)pow(10.0, exponent);
975 accum *= power;
976 }
977
978 PUSHFLOAT(accum);
979 if (pVM->state == COMPILE)
980 fliteralIm(pVM);
981
982 return(1);
983 }
984
985 #endif /* FICL_WANT_FLOAT */
986
987 /**************************************************************************
988 ** Add float words to a system's dictionary.
989 ** pSys -- Pointer to the FICL sytem to add float words to.
990 **************************************************************************/
ficlCompileFloat(FICL_SYSTEM * pSys)991 void ficlCompileFloat(FICL_SYSTEM *pSys)
992 {
993 FICL_DICT *dp = pSys->dp;
994 assert(dp);
995
996 #if FICL_WANT_FLOAT
997 dictAppendWord(dp, ">float", ToF, FW_DEFAULT);
998 /* d>f */
999 dictAppendWord(dp, "f!", Fstore, FW_DEFAULT);
1000 dictAppendWord(dp, "f*", Fmul, FW_DEFAULT);
1001 dictAppendWord(dp, "f+", Fadd, FW_DEFAULT);
1002 dictAppendWord(dp, "f-", Fsub, FW_DEFAULT);
1003 dictAppendWord(dp, "f/", Fdiv, FW_DEFAULT);
1004 dictAppendWord(dp, "f0<", FzeroLess, FW_DEFAULT);
1005 dictAppendWord(dp, "f0=", FzeroEquals, FW_DEFAULT);
1006 dictAppendWord(dp, "f<", FisLess, FW_DEFAULT);
1007 /*
1008 f>d
1009 */
1010 dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT);
1011 /*
1012 falign
1013 faligned
1014 */
1015 dictAppendWord(dp, "fconstant", Fconstant, FW_DEFAULT);
1016 dictAppendWord(dp, "fdepth", Fdepth, FW_DEFAULT);
1017 dictAppendWord(dp, "fdrop", Fdrop, FW_DEFAULT);
1018 dictAppendWord(dp, "fdup", Fdup, FW_DEFAULT);
1019 dictAppendWord(dp, "fliteral", fliteralIm, FW_IMMEDIATE);
1020 /*
1021 float+
1022 floats
1023 floor
1024 fmax
1025 fmin
1026 */
1027 dictAppendWord(dp, "f?dup", FquestionDup, FW_DEFAULT);
1028 dictAppendWord(dp, "f=", FisEqual, FW_DEFAULT);
1029 dictAppendWord(dp, "f>", FisGreater, FW_DEFAULT);
1030 dictAppendWord(dp, "f0>", FzeroGreater, FW_DEFAULT);
1031 dictAppendWord(dp, "f2drop", FtwoDrop, FW_DEFAULT);
1032 dictAppendWord(dp, "f2dup", FtwoDup, FW_DEFAULT);
1033 dictAppendWord(dp, "f2over", FtwoOver, FW_DEFAULT);
1034 dictAppendWord(dp, "f2swap", FtwoSwap, FW_DEFAULT);
1035 dictAppendWord(dp, "f+!", FplusStore, FW_DEFAULT);
1036 dictAppendWord(dp, "f+i", Faddi, FW_DEFAULT);
1037 dictAppendWord(dp, "f-i", Fsubi, FW_DEFAULT);
1038 dictAppendWord(dp, "f*i", Fmuli, FW_DEFAULT);
1039 dictAppendWord(dp, "f/i", Fdivi, FW_DEFAULT);
1040 dictAppendWord(dp, "int>float", itof, FW_DEFAULT);
1041 dictAppendWord(dp, "float>int", Ftoi, FW_DEFAULT);
1042 dictAppendWord(dp, "f.", FDot, FW_DEFAULT);
1043 dictAppendWord(dp, "f.s", displayFStack, FW_DEFAULT);
1044 dictAppendWord(dp, "fe.", EDot, FW_DEFAULT);
1045 dictAppendWord(dp, "fover", Fover, FW_DEFAULT);
1046 dictAppendWord(dp, "fnegate", Fnegate, FW_DEFAULT);
1047 dictAppendWord(dp, "fpick", Fpick, FW_DEFAULT);
1048 dictAppendWord(dp, "froll", Froll, FW_DEFAULT);
1049 dictAppendWord(dp, "frot", Frot, FW_DEFAULT);
1050 dictAppendWord(dp, "fswap", Fswap, FW_DEFAULT);
1051 dictAppendWord(dp, "i-f", isubf, FW_DEFAULT);
1052 dictAppendWord(dp, "i/f", idivf, FW_DEFAULT);
1053
1054 dictAppendWord(dp, "float>", FFrom, FW_DEFAULT);
1055
1056 dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT);
1057 dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT);
1058 dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);
1059
1060 ficlSetEnv(pSys, "floating", FICL_FALSE); /* not all required words are present */
1061 ficlSetEnv(pSys, "floating-ext", FICL_FALSE);
1062 ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK);
1063 #endif
1064 return;
1065 }
1066
1067