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
54 /*******************************************************************
55 ** Do float addition r1 + r2.
57 *******************************************************************/
58 static void Fadd(FICL_VM *pVM)
63 vmCheckFStack(pVM, 2, 1);
71 /*******************************************************************
72 ** Do float subtraction r1 - r2.
74 *******************************************************************/
75 static void Fsub(FICL_VM *pVM)
80 vmCheckFStack(pVM, 2, 1);
88 /*******************************************************************
89 ** Do float multiplication r1 * r2.
91 *******************************************************************/
92 static void Fmul(FICL_VM *pVM)
97 vmCheckFStack(pVM, 2, 1);
105 /*******************************************************************
106 ** Do float negation.
107 ** fnegate ( r -- r )
108 *******************************************************************/
109 static void Fnegate(FICL_VM *pVM)
114 vmCheckFStack(pVM, 1, 1);
121 /*******************************************************************
122 ** Do float division r1 / r2.
124 *******************************************************************/
125 static void Fdiv(FICL_VM *pVM)
130 vmCheckFStack(pVM, 2, 1);
138 /*******************************************************************
139 ** Do float + integer r + n.
141 *******************************************************************/
142 static void Faddi(FICL_VM *pVM)
147 vmCheckFStack(pVM, 1, 1);
148 vmCheckStack(pVM, 1, 0);
151 f = (FICL_FLOAT)POPINT();
156 /*******************************************************************
157 ** Do float - integer r - n.
159 *******************************************************************/
160 static void Fsubi(FICL_VM *pVM)
165 vmCheckFStack(pVM, 1, 1);
166 vmCheckStack(pVM, 1, 0);
170 f -= (FICL_FLOAT)POPINT();
174 /*******************************************************************
175 ** Do float * integer r * n.
177 *******************************************************************/
178 static void Fmuli(FICL_VM *pVM)
183 vmCheckFStack(pVM, 1, 1);
184 vmCheckStack(pVM, 1, 0);
187 f = (FICL_FLOAT)POPINT();
192 /*******************************************************************
193 ** Do float / integer r / n.
195 *******************************************************************/
196 static void Fdivi(FICL_VM *pVM)
201 vmCheckFStack(pVM, 1, 1);
202 vmCheckStack(pVM, 1, 0);
206 f /= (FICL_FLOAT)POPINT();
210 /*******************************************************************
211 ** Do integer - float n - r.
213 *******************************************************************/
214 static void isubf(FICL_VM *pVM)
219 vmCheckFStack(pVM, 1, 1);
220 vmCheckStack(pVM, 1, 0);
223 f = (FICL_FLOAT)POPINT();
228 /*******************************************************************
229 ** Do integer / float n / r.
231 *******************************************************************/
232 static void idivf(FICL_VM *pVM)
237 vmCheckFStack(pVM, 1,1);
238 vmCheckStack(pVM, 1, 0);
241 f = (FICL_FLOAT)POPINT();
246 /*******************************************************************
247 ** Do integer to float conversion.
248 ** int>float ( n -- r )
249 *******************************************************************/
250 static void itof(FICL_VM *pVM)
255 vmCheckStack(pVM, 1, 0);
256 vmCheckFStack(pVM, 0, 1);
263 /*******************************************************************
264 ** Do float to integer conversion.
265 ** float>int ( r -- n )
266 *******************************************************************/
267 static void Ftoi(FICL_VM *pVM)
272 vmCheckStack(pVM, 0, 1);
273 vmCheckFStack(pVM, 1, 0);
276 i = (FICL_INT)POPFLOAT();
280 /*******************************************************************
281 ** Floating point constant execution word.
282 *******************************************************************/
283 void FconstantParen(FICL_VM *pVM)
285 FICL_WORD *pFW = pVM->runningWord;
288 vmCheckFStack(pVM, 0, 1);
291 PUSHFLOAT(pFW->param[0].f);
294 /*******************************************************************
295 ** Create a floating point constant.
296 ** fconstant ( r -"name"- )
297 *******************************************************************/
298 static void Fconstant(FICL_VM *pVM)
300 FICL_DICT *dp = vmGetDict(pVM);
301 STRINGINFO si = vmGetWord(pVM);
304 vmCheckFStack(pVM, 1, 0);
307 dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT);
308 dictAppendCell(dp, stackPop(pVM->fStack));
311 /*******************************************************************
312 ** Display a float in decimal format.
314 *******************************************************************/
315 static void FDot(FICL_VM *pVM)
320 vmCheckFStack(pVM, 1, 0);
324 sprintf(pVM->pad,"%#f ",f);
325 vmTextOut(pVM, pVM->pad, 0);
328 /*******************************************************************
329 ** Display a float in engineering format.
331 *******************************************************************/
332 static void EDot(FICL_VM *pVM)
337 vmCheckFStack(pVM, 1, 0);
341 sprintf(pVM->pad,"%#e ",f);
342 vmTextOut(pVM, pVM->pad, 0);
345 /**************************************************************************
346 d i s p l a y FS t a c k
347 ** Display the parameter stack (code for "f.s")
349 **************************************************************************/
350 static void displayFStack(FICL_VM *pVM)
352 int d = stackDepth(pVM->fStack);
356 vmCheckFStack(pVM, 0, 0);
358 vmTextOut(pVM, "F:", 0);
361 vmTextOut(pVM, "[0]", 0);
364 ltoa(d, &pVM->pad[1], pVM->base);
366 strcat(pVM->pad,"] ");
367 vmTextOut(pVM,pVM->pad,0);
369 pCell = pVM->fStack->sp - d;
370 for (i = 0; i < d; i++)
372 sprintf(pVM->pad,"%#f ",(*pCell++).f);
373 vmTextOut(pVM,pVM->pad,0);
378 /*******************************************************************
379 ** Do float stack depth.
381 *******************************************************************/
382 static void Fdepth(FICL_VM *pVM)
387 vmCheckStack(pVM, 0, 1);
390 i = stackDepth(pVM->fStack);
394 /*******************************************************************
395 ** Do float stack drop.
397 *******************************************************************/
398 static void Fdrop(FICL_VM *pVM)
401 vmCheckFStack(pVM, 1, 0);
407 /*******************************************************************
408 ** Do float stack 2drop.
410 *******************************************************************/
411 static void FtwoDrop(FICL_VM *pVM)
414 vmCheckFStack(pVM, 2, 0);
420 /*******************************************************************
421 ** Do float stack dup.
423 *******************************************************************/
424 static void Fdup(FICL_VM *pVM)
427 vmCheckFStack(pVM, 1, 2);
433 /*******************************************************************
434 ** Do float stack 2dup.
435 ** f2dup ( r1 r2 -- r1 r2 r1 r2 )
436 *******************************************************************/
437 static void FtwoDup(FICL_VM *pVM)
440 vmCheckFStack(pVM, 2, 4);
447 /*******************************************************************
448 ** Do float stack over.
449 ** fover ( r1 r2 -- r1 r2 r1 )
450 *******************************************************************/
451 static void Fover(FICL_VM *pVM)
454 vmCheckFStack(pVM, 2, 3);
460 /*******************************************************************
461 ** Do float stack 2over.
462 ** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
463 *******************************************************************/
464 static void FtwoOver(FICL_VM *pVM)
467 vmCheckFStack(pVM, 4, 6);
474 /*******************************************************************
475 ** Do float stack pick.
477 *******************************************************************/
478 static void Fpick(FICL_VM *pVM)
483 vmCheckFStack(pVM, c.i+1, c.i+2);
489 /*******************************************************************
490 ** Do float stack ?dup.
492 *******************************************************************/
493 static void FquestionDup(FICL_VM *pVM)
498 vmCheckFStack(pVM, 1, 2);
506 /*******************************************************************
507 ** Do float stack roll.
509 *******************************************************************/
510 static void Froll(FICL_VM *pVM)
516 vmCheckFStack(pVM, i+1, i+1);
522 /*******************************************************************
523 ** Do float stack -roll.
525 *******************************************************************/
526 static void FminusRoll(FICL_VM *pVM)
532 vmCheckFStack(pVM, i+1, i+1);
538 /*******************************************************************
539 ** Do float stack rot.
540 ** frot ( r1 r2 r3 -- r2 r3 r1 )
541 *******************************************************************/
542 static void Frot(FICL_VM *pVM)
545 vmCheckFStack(pVM, 3, 3);
551 /*******************************************************************
552 ** Do float stack -rot.
553 ** f-rot ( r1 r2 r3 -- r3 r1 r2 )
554 *******************************************************************/
555 static void Fminusrot(FICL_VM *pVM)
558 vmCheckFStack(pVM, 3, 3);
564 /*******************************************************************
565 ** Do float stack swap.
566 ** fswap ( r1 r2 -- r2 r1 )
567 *******************************************************************/
568 static void Fswap(FICL_VM *pVM)
571 vmCheckFStack(pVM, 2, 2);
577 /*******************************************************************
578 ** Do float stack 2swap
579 ** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
580 *******************************************************************/
581 static void FtwoSwap(FICL_VM *pVM)
584 vmCheckFStack(pVM, 4, 4);
591 /*******************************************************************
592 ** Get a floating point number from a variable.
594 *******************************************************************/
595 static void Ffetch(FICL_VM *pVM)
600 vmCheckFStack(pVM, 0, 1);
601 vmCheckStack(pVM, 1, 0);
604 pCell = (CELL *)POPPTR();
608 /*******************************************************************
609 ** Store a floating point number into a variable.
611 *******************************************************************/
612 static void Fstore(FICL_VM *pVM)
617 vmCheckFStack(pVM, 1, 0);
618 vmCheckStack(pVM, 1, 0);
621 pCell = (CELL *)POPPTR();
622 pCell->f = POPFLOAT();
625 /*******************************************************************
626 ** Add a floating point number to contents of a variable.
628 *******************************************************************/
629 static void FplusStore(FICL_VM *pVM)
634 vmCheckStack(pVM, 1, 0);
635 vmCheckFStack(pVM, 1, 0);
638 pCell = (CELL *)POPPTR();
639 pCell->f += POPFLOAT();
642 /*******************************************************************
643 ** Floating point literal execution word.
644 *******************************************************************/
645 static void fliteralParen(FICL_VM *pVM)
648 vmCheckStack(pVM, 0, 1);
651 PUSHFLOAT(*(float*)(pVM->ip));
652 vmBranchRelative(pVM, 1);
655 /*******************************************************************
656 ** Compile a floating point literal.
657 *******************************************************************/
658 static void fliteralIm(FICL_VM *pVM)
660 FICL_DICT *dp = vmGetDict(pVM);
661 FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)");
664 vmCheckFStack(pVM, 1, 0);
667 dictAppendCell(dp, LVALUEtoCELL(pfLitParen));
668 dictAppendCell(dp, stackPop(pVM->fStack));
671 /*******************************************************************
672 ** Do float 0= comparison r = 0.0.
674 *******************************************************************/
675 static void FzeroEquals(FICL_VM *pVM)
680 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
681 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
684 c.i = FICL_BOOL(POPFLOAT() == 0);
688 /*******************************************************************
689 ** Do float 0< comparison r < 0.0.
691 *******************************************************************/
692 static void FzeroLess(FICL_VM *pVM)
697 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
698 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
701 c.i = FICL_BOOL(POPFLOAT() < 0);
705 /*******************************************************************
706 ** Do float 0> comparison r > 0.0.
708 *******************************************************************/
709 static void FzeroGreater(FICL_VM *pVM)
714 vmCheckFStack(pVM, 1, 0);
715 vmCheckStack(pVM, 0, 1);
718 c.i = FICL_BOOL(POPFLOAT() > 0);
722 /*******************************************************************
723 ** Do float = comparison r1 = r2.
724 ** f= ( r1 r2 -- T/F )
725 *******************************************************************/
726 static void FisEqual(FICL_VM *pVM)
731 vmCheckFStack(pVM, 2, 0);
732 vmCheckStack(pVM, 0, 1);
737 PUSHINT(FICL_BOOL(x == y));
740 /*******************************************************************
741 ** Do float < comparison r1 < r2.
742 ** f< ( r1 r2 -- T/F )
743 *******************************************************************/
744 static void FisLess(FICL_VM *pVM)
749 vmCheckFStack(pVM, 2, 0);
750 vmCheckStack(pVM, 0, 1);
755 PUSHINT(FICL_BOOL(x < y));
758 /*******************************************************************
759 ** Do float > comparison r1 > r2.
760 ** f> ( r1 r2 -- T/F )
761 *******************************************************************/
762 static void FisGreater(FICL_VM *pVM)
767 vmCheckFStack(pVM, 2, 0);
768 vmCheckStack(pVM, 0, 1);
773 PUSHINT(FICL_BOOL(x > y));
777 /*******************************************************************
778 ** Move float to param stack (assumes they both fit in a single CELL)
780 *******************************************************************/
781 static void FFrom(FICL_VM *pVM)
786 vmCheckFStack(pVM, 1, 0);
787 vmCheckStack(pVM, 0, 1);
790 c = stackPop(pVM->fStack);
791 stackPush(pVM->pStack, c);
795 static void ToF(FICL_VM *pVM)
800 vmCheckFStack(pVM, 0, 1);
801 vmCheckStack(pVM, 1, 0);
804 c = stackPop(pVM->pStack);
805 stackPush(pVM->fStack, c);
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
814 **************************************************************************/
818 typedef enum _floatParseState
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 **************************************************************************/
833 int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
835 unsigned char ch, digit;
841 FICL_INT exponent = 0;
843 FloatParseState estate = FPS_START;
846 vmCheckFStack(pVM, 0, 1);
850 ** floating point numbers only allowed in base 10
857 count = (FICL_COUNT)SI_COUNT(si);
859 /* Loop through the string's characters. */
860 while ((count--) && ((ch = *cp++) != 0))
864 /* At start of the number so look for a sign. */
877 } /* Note! Drop through to FPS_ININT */
879 **Converting integer part of number.
880 ** Only allow digits, decimal and 'E'.
888 else if ((ch == 'e') || (ch == 'E'))
890 estate = FPS_STARTEXP;
894 digit = (unsigned char)(ch - '0');
898 accum = accum * 10 + digit;
904 ** Processing the fraction part of number.
905 ** Only allow digits and 'E'
909 if ((ch == 'e') || (ch == 'E'))
911 estate = FPS_STARTEXP;
915 digit = (unsigned char)(ch - '0');
919 accum += digit * mant;
924 /* Start processing the exponent part of number. */
939 } /* Note! Drop through to FPS_INEXP */
941 ** Processing the exponent part of number.
942 ** Only allow digits.
946 digit = (unsigned char)(ch - '0');
950 exponent = exponent * 10 + digit;
957 /* If parser never made it to the exponent this is not a float. */
958 if (estate < FPS_STARTEXP)
961 /* Set the sign of the number. */
965 /* If exponent is not 0 then adjust number by it. */
968 /* Determine if exponent is negative. */
971 exponent = -exponent;
974 power = (float)pow(10.0, exponent);
979 if (pVM->state == COMPILE)
985 #endif /* FICL_WANT_FLOAT */
987 /**************************************************************************
988 ** Add float words to a system's dictionary.
989 ** pSys -- Pointer to the FICL sytem to add float words to.
990 **************************************************************************/
991 void ficlCompileFloat(FICL_SYSTEM *pSys)
993 FICL_DICT *dp = pSys->dp;
997 dictAppendWord(dp, ">float", ToF, FW_DEFAULT);
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);
1010 dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT);
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);
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);
1054 dictAppendWord(dp, "float>", FFrom, FW_DEFAULT);
1056 dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT);
1057 dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT);
1058 dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);
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);