1 /*******************************************************************
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)
7 ** $Id: float.c,v 1.8 2001/12/05 07:21:34 jsadler Exp $
8 *******************************************************************/
10 ** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
11 ** All rights reserved.
13 ** Get the latest Ficl release at http://ficl.sourceforge.net
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.
20 ** L I C E N S E and D I S C L A I M E R
22 ** Redistribution and use in source and binary forms, with or without
23 ** modification, are permitted provided that the following conditions
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.
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
55 /*******************************************************************
56 ** Do float addition r1 + r2.
58 *******************************************************************/
59 static void Fadd(FICL_VM *pVM)
64 vmCheckFStack(pVM, 2, 1);
72 /*******************************************************************
73 ** Do float subtraction r1 - r2.
75 *******************************************************************/
76 static void Fsub(FICL_VM *pVM)
81 vmCheckFStack(pVM, 2, 1);
89 /*******************************************************************
90 ** Do float multiplication r1 * r2.
92 *******************************************************************/
93 static void Fmul(FICL_VM *pVM)
98 vmCheckFStack(pVM, 2, 1);
106 /*******************************************************************
107 ** Do float negation.
108 ** fnegate ( r -- r )
109 *******************************************************************/
110 static void Fnegate(FICL_VM *pVM)
115 vmCheckFStack(pVM, 1, 1);
122 /*******************************************************************
123 ** Do float division r1 / r2.
125 *******************************************************************/
126 static void Fdiv(FICL_VM *pVM)
131 vmCheckFStack(pVM, 2, 1);
139 /*******************************************************************
140 ** Do float + integer r + n.
142 *******************************************************************/
143 static void Faddi(FICL_VM *pVM)
148 vmCheckFStack(pVM, 1, 1);
149 vmCheckStack(pVM, 1, 0);
152 f = (FICL_FLOAT)POPINT();
157 /*******************************************************************
158 ** Do float - integer r - n.
160 *******************************************************************/
161 static void Fsubi(FICL_VM *pVM)
166 vmCheckFStack(pVM, 1, 1);
167 vmCheckStack(pVM, 1, 0);
171 f -= (FICL_FLOAT)POPINT();
175 /*******************************************************************
176 ** Do float * integer r * n.
178 *******************************************************************/
179 static void Fmuli(FICL_VM *pVM)
184 vmCheckFStack(pVM, 1, 1);
185 vmCheckStack(pVM, 1, 0);
188 f = (FICL_FLOAT)POPINT();
193 /*******************************************************************
194 ** Do float / integer r / n.
196 *******************************************************************/
197 static void Fdivi(FICL_VM *pVM)
202 vmCheckFStack(pVM, 1, 1);
203 vmCheckStack(pVM, 1, 0);
207 f /= (FICL_FLOAT)POPINT();
211 /*******************************************************************
212 ** Do integer - float n - r.
214 *******************************************************************/
215 static void isubf(FICL_VM *pVM)
220 vmCheckFStack(pVM, 1, 1);
221 vmCheckStack(pVM, 1, 0);
224 f = (FICL_FLOAT)POPINT();
229 /*******************************************************************
230 ** Do integer / float n / r.
232 *******************************************************************/
233 static void idivf(FICL_VM *pVM)
238 vmCheckFStack(pVM, 1,1);
239 vmCheckStack(pVM, 1, 0);
242 f = (FICL_FLOAT)POPINT();
247 /*******************************************************************
248 ** Do integer to float conversion.
249 ** int>float ( n -- r )
250 *******************************************************************/
251 static void itof(FICL_VM *pVM)
256 vmCheckStack(pVM, 1, 0);
257 vmCheckFStack(pVM, 0, 1);
264 /*******************************************************************
265 ** Do float to integer conversion.
266 ** float>int ( r -- n )
267 *******************************************************************/
268 static void Ftoi(FICL_VM *pVM)
273 vmCheckStack(pVM, 0, 1);
274 vmCheckFStack(pVM, 1, 0);
277 i = (FICL_INT)POPFLOAT();
281 /*******************************************************************
282 ** Floating point constant execution word.
283 *******************************************************************/
284 void FconstantParen(FICL_VM *pVM)
286 FICL_WORD *pFW = pVM->runningWord;
289 vmCheckFStack(pVM, 0, 1);
292 PUSHFLOAT(pFW->param[0].f);
295 /*******************************************************************
296 ** Create a floating point constant.
297 ** fconstant ( r -"name"- )
298 *******************************************************************/
299 static void Fconstant(FICL_VM *pVM)
301 FICL_DICT *dp = vmGetDict(pVM);
302 STRINGINFO si = vmGetWord(pVM);
305 vmCheckFStack(pVM, 1, 0);
308 dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT);
309 dictAppendCell(dp, stackPop(pVM->fStack));
312 /*******************************************************************
313 ** Display a float in decimal format.
315 *******************************************************************/
316 static void FDot(FICL_VM *pVM)
321 vmCheckFStack(pVM, 1, 0);
325 sprintf(pVM->pad,"%#f ",f);
326 vmTextOut(pVM, pVM->pad, 0);
329 /*******************************************************************
330 ** Display a float in engineering format.
332 *******************************************************************/
333 static void EDot(FICL_VM *pVM)
338 vmCheckFStack(pVM, 1, 0);
342 sprintf(pVM->pad,"%#e ",f);
343 vmTextOut(pVM, pVM->pad, 0);
346 /**************************************************************************
347 d i s p l a y FS t a c k
348 ** Display the parameter stack (code for "f.s")
350 **************************************************************************/
351 static void displayFStack(FICL_VM *pVM)
353 int d = stackDepth(pVM->fStack);
357 vmCheckFStack(pVM, 0, 0);
359 vmTextOut(pVM, "F:", 0);
362 vmTextOut(pVM, "[0]", 0);
365 ltoa(d, &pVM->pad[1], pVM->base);
367 strcat(pVM->pad,"] ");
368 vmTextOut(pVM,pVM->pad,0);
370 pCell = pVM->fStack->sp - d;
371 for (i = 0; i < d; i++)
373 sprintf(pVM->pad,"%#f ",(*pCell++).f);
374 vmTextOut(pVM,pVM->pad,0);
379 /*******************************************************************
380 ** Do float stack depth.
382 *******************************************************************/
383 static void Fdepth(FICL_VM *pVM)
388 vmCheckStack(pVM, 0, 1);
391 i = stackDepth(pVM->fStack);
395 /*******************************************************************
396 ** Do float stack drop.
398 *******************************************************************/
399 static void Fdrop(FICL_VM *pVM)
402 vmCheckFStack(pVM, 1, 0);
408 /*******************************************************************
409 ** Do float stack 2drop.
411 *******************************************************************/
412 static void FtwoDrop(FICL_VM *pVM)
415 vmCheckFStack(pVM, 2, 0);
421 /*******************************************************************
422 ** Do float stack dup.
424 *******************************************************************/
425 static void Fdup(FICL_VM *pVM)
428 vmCheckFStack(pVM, 1, 2);
434 /*******************************************************************
435 ** Do float stack 2dup.
436 ** f2dup ( r1 r2 -- r1 r2 r1 r2 )
437 *******************************************************************/
438 static void FtwoDup(FICL_VM *pVM)
441 vmCheckFStack(pVM, 2, 4);
448 /*******************************************************************
449 ** Do float stack over.
450 ** fover ( r1 r2 -- r1 r2 r1 )
451 *******************************************************************/
452 static void Fover(FICL_VM *pVM)
455 vmCheckFStack(pVM, 2, 3);
461 /*******************************************************************
462 ** Do float stack 2over.
463 ** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
464 *******************************************************************/
465 static void FtwoOver(FICL_VM *pVM)
468 vmCheckFStack(pVM, 4, 6);
475 /*******************************************************************
476 ** Do float stack pick.
478 *******************************************************************/
479 static void Fpick(FICL_VM *pVM)
484 vmCheckFStack(pVM, c.i+1, c.i+2);
490 /*******************************************************************
491 ** Do float stack ?dup.
493 *******************************************************************/
494 static void FquestionDup(FICL_VM *pVM)
499 vmCheckFStack(pVM, 1, 2);
507 /*******************************************************************
508 ** Do float stack roll.
510 *******************************************************************/
511 static void Froll(FICL_VM *pVM)
517 vmCheckFStack(pVM, i+1, i+1);
523 /*******************************************************************
524 ** Do float stack -roll.
526 *******************************************************************/
527 static void FminusRoll(FICL_VM *pVM)
533 vmCheckFStack(pVM, i+1, i+1);
539 /*******************************************************************
540 ** Do float stack rot.
541 ** frot ( r1 r2 r3 -- r2 r3 r1 )
542 *******************************************************************/
543 static void Frot(FICL_VM *pVM)
546 vmCheckFStack(pVM, 3, 3);
552 /*******************************************************************
553 ** Do float stack -rot.
554 ** f-rot ( r1 r2 r3 -- r3 r1 r2 )
555 *******************************************************************/
556 static void Fminusrot(FICL_VM *pVM)
559 vmCheckFStack(pVM, 3, 3);
565 /*******************************************************************
566 ** Do float stack swap.
567 ** fswap ( r1 r2 -- r2 r1 )
568 *******************************************************************/
569 static void Fswap(FICL_VM *pVM)
572 vmCheckFStack(pVM, 2, 2);
578 /*******************************************************************
579 ** Do float stack 2swap
580 ** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
581 *******************************************************************/
582 static void FtwoSwap(FICL_VM *pVM)
585 vmCheckFStack(pVM, 4, 4);
592 /*******************************************************************
593 ** Get a floating point number from a variable.
595 *******************************************************************/
596 static void Ffetch(FICL_VM *pVM)
601 vmCheckFStack(pVM, 0, 1);
602 vmCheckStack(pVM, 1, 0);
605 pCell = (CELL *)POPPTR();
609 /*******************************************************************
610 ** Store a floating point number into a variable.
612 *******************************************************************/
613 static void Fstore(FICL_VM *pVM)
618 vmCheckFStack(pVM, 1, 0);
619 vmCheckStack(pVM, 1, 0);
622 pCell = (CELL *)POPPTR();
623 pCell->f = POPFLOAT();
626 /*******************************************************************
627 ** Add a floating point number to contents of a variable.
629 *******************************************************************/
630 static void FplusStore(FICL_VM *pVM)
635 vmCheckStack(pVM, 1, 0);
636 vmCheckFStack(pVM, 1, 0);
639 pCell = (CELL *)POPPTR();
640 pCell->f += POPFLOAT();
643 /*******************************************************************
644 ** Floating point literal execution word.
645 *******************************************************************/
646 static void fliteralParen(FICL_VM *pVM)
649 vmCheckStack(pVM, 0, 1);
652 PUSHFLOAT(*(float*)(pVM->ip));
653 vmBranchRelative(pVM, 1);
656 /*******************************************************************
657 ** Compile a floating point literal.
658 *******************************************************************/
659 static void fliteralIm(FICL_VM *pVM)
661 FICL_DICT *dp = vmGetDict(pVM);
662 FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)");
665 vmCheckFStack(pVM, 1, 0);
668 dictAppendCell(dp, LVALUEtoCELL(pfLitParen));
669 dictAppendCell(dp, stackPop(pVM->fStack));
672 /*******************************************************************
673 ** Do float 0= comparison r = 0.0.
675 *******************************************************************/
676 static void FzeroEquals(FICL_VM *pVM)
681 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
682 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
685 c.i = FICL_BOOL(POPFLOAT() == 0);
689 /*******************************************************************
690 ** Do float 0< comparison r < 0.0.
692 *******************************************************************/
693 static void FzeroLess(FICL_VM *pVM)
698 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
699 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
702 c.i = FICL_BOOL(POPFLOAT() < 0);
706 /*******************************************************************
707 ** Do float 0> comparison r > 0.0.
709 *******************************************************************/
710 static void FzeroGreater(FICL_VM *pVM)
715 vmCheckFStack(pVM, 1, 0);
716 vmCheckStack(pVM, 0, 1);
719 c.i = FICL_BOOL(POPFLOAT() > 0);
723 /*******************************************************************
724 ** Do float = comparison r1 = r2.
725 ** f= ( r1 r2 -- T/F )
726 *******************************************************************/
727 static void FisEqual(FICL_VM *pVM)
732 vmCheckFStack(pVM, 2, 0);
733 vmCheckStack(pVM, 0, 1);
738 PUSHINT(FICL_BOOL(x == y));
741 /*******************************************************************
742 ** Do float < comparison r1 < r2.
743 ** f< ( r1 r2 -- T/F )
744 *******************************************************************/
745 static void FisLess(FICL_VM *pVM)
750 vmCheckFStack(pVM, 2, 0);
751 vmCheckStack(pVM, 0, 1);
756 PUSHINT(FICL_BOOL(x < y));
759 /*******************************************************************
760 ** Do float > comparison r1 > r2.
761 ** f> ( r1 r2 -- T/F )
762 *******************************************************************/
763 static void FisGreater(FICL_VM *pVM)
768 vmCheckFStack(pVM, 2, 0);
769 vmCheckStack(pVM, 0, 1);
774 PUSHINT(FICL_BOOL(x > y));
778 /*******************************************************************
779 ** Move float to param stack (assumes they both fit in a single CELL)
781 *******************************************************************/
782 static void FFrom(FICL_VM *pVM)
787 vmCheckFStack(pVM, 1, 0);
788 vmCheckStack(pVM, 0, 1);
791 c = stackPop(pVM->fStack);
792 stackPush(pVM->pStack, c);
796 static void ToF(FICL_VM *pVM)
801 vmCheckFStack(pVM, 0, 1);
802 vmCheckStack(pVM, 1, 0);
805 c = stackPop(pVM->pStack);
806 stackPush(pVM->fStack, c);
811 /**************************************************************************
812 F l o a t P a r s e S t a t e
813 ** Enum to determine the current segement of a floating point number
815 **************************************************************************/
819 typedef enum _floatParseState
828 /**************************************************************************
829 f i c l P a r s e F l o a t N u m b e r
830 ** pVM -- Virtual Machine pointer.
831 ** si -- String to parse.
832 ** Returns 1 if successful, 0 if not.
833 **************************************************************************/
834 int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
836 unsigned char ch, digit;
842 FICL_INT exponent = 0;
844 FloatParseState estate = FPS_START;
847 vmCheckFStack(pVM, 0, 1);
851 ** floating point numbers only allowed in base 10
858 count = (FICL_COUNT)SI_COUNT(si);
860 /* Loop through the string's characters. */
861 while ((count--) && ((ch = *cp++) != 0))
865 /* At start of the number so look for a sign. */
878 } /* Note! Drop through to FPS_ININT */
880 **Converting integer part of number.
881 ** Only allow digits, decimal and 'E'.
889 else if ((ch == 'e') || (ch == 'E'))
891 estate = FPS_STARTEXP;
895 digit = (unsigned char)(ch - '0');
899 accum = accum * 10 + digit;
905 ** Processing the fraction part of number.
906 ** Only allow digits and 'E'
910 if ((ch == 'e') || (ch == 'E'))
912 estate = FPS_STARTEXP;
916 digit = (unsigned char)(ch - '0');
920 accum += digit * mant;
925 /* Start processing the exponent part of number. */
940 } /* Note! Drop through to FPS_INEXP */
942 ** Processing the exponent part of number.
943 ** Only allow digits.
947 digit = (unsigned char)(ch - '0');
951 exponent = exponent * 10 + digit;
958 /* If parser never made it to the exponent this is not a float. */
959 if (estate < FPS_STARTEXP)
962 /* Set the sign of the number. */
966 /* If exponent is not 0 then adjust number by it. */
969 /* Determine if exponent is negative. */
972 exponent = -exponent;
975 power = (float)pow(10.0, exponent);
980 if (pVM->state == COMPILE)
986 #endif /* FICL_WANT_FLOAT */
988 /**************************************************************************
989 ** Add float words to a system's dictionary.
990 ** pSys -- Pointer to the FICL sytem to add float words to.
991 **************************************************************************/
992 void ficlCompileFloat(FICL_SYSTEM *pSys)
994 FICL_DICT *dp = pSys->dp;
998 dictAppendWord(dp, ">float", ToF, FW_DEFAULT);
1000 dictAppendWord(dp, "f!", Fstore, FW_DEFAULT);
1001 dictAppendWord(dp, "f*", Fmul, FW_DEFAULT);
1002 dictAppendWord(dp, "f+", Fadd, FW_DEFAULT);
1003 dictAppendWord(dp, "f-", Fsub, FW_DEFAULT);
1004 dictAppendWord(dp, "f/", Fdiv, FW_DEFAULT);
1005 dictAppendWord(dp, "f0<", FzeroLess, FW_DEFAULT);
1006 dictAppendWord(dp, "f0=", FzeroEquals, FW_DEFAULT);
1007 dictAppendWord(dp, "f<", FisLess, FW_DEFAULT);
1011 dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT);
1016 dictAppendWord(dp, "fconstant", Fconstant, FW_DEFAULT);
1017 dictAppendWord(dp, "fdepth", Fdepth, FW_DEFAULT);
1018 dictAppendWord(dp, "fdrop", Fdrop, FW_DEFAULT);
1019 dictAppendWord(dp, "fdup", Fdup, FW_DEFAULT);
1020 dictAppendWord(dp, "fliteral", fliteralIm, FW_IMMEDIATE);
1028 dictAppendWord(dp, "f?dup", FquestionDup, FW_DEFAULT);
1029 dictAppendWord(dp, "f=", FisEqual, FW_DEFAULT);
1030 dictAppendWord(dp, "f>", FisGreater, FW_DEFAULT);
1031 dictAppendWord(dp, "f0>", FzeroGreater, FW_DEFAULT);
1032 dictAppendWord(dp, "f2drop", FtwoDrop, FW_DEFAULT);
1033 dictAppendWord(dp, "f2dup", FtwoDup, FW_DEFAULT);
1034 dictAppendWord(dp, "f2over", FtwoOver, FW_DEFAULT);
1035 dictAppendWord(dp, "f2swap", FtwoSwap, FW_DEFAULT);
1036 dictAppendWord(dp, "f+!", FplusStore, FW_DEFAULT);
1037 dictAppendWord(dp, "f+i", Faddi, FW_DEFAULT);
1038 dictAppendWord(dp, "f-i", Fsubi, FW_DEFAULT);
1039 dictAppendWord(dp, "f*i", Fmuli, FW_DEFAULT);
1040 dictAppendWord(dp, "f/i", Fdivi, FW_DEFAULT);
1041 dictAppendWord(dp, "int>float", itof, FW_DEFAULT);
1042 dictAppendWord(dp, "float>int", Ftoi, FW_DEFAULT);
1043 dictAppendWord(dp, "f.", FDot, FW_DEFAULT);
1044 dictAppendWord(dp, "f.s", displayFStack, FW_DEFAULT);
1045 dictAppendWord(dp, "fe.", EDot, FW_DEFAULT);
1046 dictAppendWord(dp, "fover", Fover, FW_DEFAULT);
1047 dictAppendWord(dp, "fnegate", Fnegate, FW_DEFAULT);
1048 dictAppendWord(dp, "fpick", Fpick, FW_DEFAULT);
1049 dictAppendWord(dp, "froll", Froll, FW_DEFAULT);
1050 dictAppendWord(dp, "frot", Frot, FW_DEFAULT);
1051 dictAppendWord(dp, "fswap", Fswap, FW_DEFAULT);
1052 dictAppendWord(dp, "i-f", isubf, FW_DEFAULT);
1053 dictAppendWord(dp, "i/f", idivf, FW_DEFAULT);
1055 dictAppendWord(dp, "float>", FFrom, FW_DEFAULT);
1057 dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT);
1058 dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT);
1059 dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);
1061 ficlSetEnv(pSys, "floating", FICL_FALSE); /* not all required words are present */
1062 ficlSetEnv(pSys, "floating-ext", FICL_FALSE);
1063 ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK);