ref: 9626ec0e5545ea993c954d6faa25a5fb95b0bb4c
parent: 54ad7b99c3550311b01db0f45b162189f54d713d
author: jsadler <jsadler@ficl.sf.net>
date: Wed Apr 25 13:39:00 CDT 2001
*** empty log message ***
--- /dev/null
+++ b/float.c
@@ -1,0 +1,1001 @@
+/*******************************************************************
+** f l o a t . c
+** Forth Inspired Command Language
+** ANS Forth FLOAT word-set written in C
+** Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu)
+** Created: Apr 2001
+** $Id: float.c,v 1.0 2001/04/25 18:38:31 jsadler Exp $
+*******************************************************************/
+/*
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** I am interested in hearing from anyone who uses ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the ficl release (yay!), please
+** send me email at the address above.
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+#include "ficl.h"
+
+#if FICL_WANT_FLOAT
+
+/*******************************************************************
+** Do float addition r1 + r2.
+** f+ ( r1 r2 -- r )
+*******************************************************************/
+static void Fadd(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 1);
+#endif
+
+ f = POPFLOAT() + GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float subtraction r1 - r2.
+** f- ( r1 r2 -- r )
+*******************************************************************/
+static void Fsub(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 1);
+#endif
+
+ f = POPFLOAT();
+ f = GETTOPF().f - f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float multiplication r1 * r2.
+** f* ( r1 r2 -- r )
+*******************************************************************/
+static void Fmul(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 1);
+#endif
+
+ f = POPFLOAT() * GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float negation.
+** fnegate ( r -- r )
+*******************************************************************/
+static void Fnegate(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+#endif
+
+ f = -GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float division r1 / r2.
+** f/ ( r1 r2 -- r )
+*******************************************************************/
+static void Fdiv(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 1);
+#endif
+
+ f = POPFLOAT();
+ f = GETTOPF().f / f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float + integer r + n.
+** f+i ( r n -- r )
+*******************************************************************/
+static void Faddi(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ f = (float)POPINT() + GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float - integer r - n.
+** f-i ( r n -- r )
+*******************************************************************/
+static void Fsubi(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ f = GETTOPF().f - (float)POPINT();
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float * integer r * n.
+** f*i ( r n -- r )
+*******************************************************************/
+static void Fmuli(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ f = (float)POPINT() * GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do float / integer r / n.
+** f/i ( r n -- r )
+*******************************************************************/
+static void Fdivi(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ f = GETTOPF().f / (float)POPINT();
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do integer - float n - r.
+** i-f ( n r -- r )
+*******************************************************************/
+static void isubf(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ f = (float)POPINT() - GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do integer / float n / r.
+** i/f ( n r -- r )
+*******************************************************************/
+static void idivf(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1,1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ f = (float)POPINT() / GETTOPF().f;
+ SETTOPF(f);
+}
+
+/*******************************************************************
+** Do integer to float conversion.
+** int>float ( n -- r )
+*******************************************************************/
+static void itof(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+ vmCheckFStack(pVM, 0, 1);
+#endif
+
+ f = (float)POPINT();
+ PUSHFLOAT(f);
+}
+
+/*******************************************************************
+** Do float to integer conversion.
+** float>int ( r -- n )
+*******************************************************************/
+static void Ftoi(FICL_VM *pVM)
+{+ FICL_INT i;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ i = (FICL_INT)POPFLOAT();
+ PUSHINT(i);
+}
+
+/*******************************************************************
+** Floating point constant execution word.
+*******************************************************************/
+void FconstantParen(FICL_VM *pVM)
+{+ FICL_WORD *pFW = pVM->runningWord;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 0, 1);
+#endif
+
+ PUSHFLOAT(pFW->param[0].f);
+}
+
+/*******************************************************************
+** Create a floating point constant.
+** fconstant ( r -"name"- )
+*******************************************************************/
+static void Fconstant(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ STRINGINFO si = vmGetWord(pVM);
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT);
+ dictAppendCell(dp, stackPop(pVM->fStack));
+}
+
+/*******************************************************************
+** Display a float in decimal format.
+** f. ( r -- )
+*******************************************************************/
+static void FDot(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ f = POPFLOAT();
+ sprintf(pVM->pad,"%#f ",f);
+ vmTextOut(pVM, pVM->pad, 0);
+}
+
+/*******************************************************************
+** Display a float in engineering format.
+** fe. ( r -- )
+*******************************************************************/
+static void EDot(FICL_VM *pVM)
+{+ float f;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ f = POPFLOAT();
+ sprintf(pVM->pad,"%#e ",f);
+ vmTextOut(pVM, pVM->pad, 0);
+}
+
+/**************************************************************************
+ d i s p l a y FS t a c k
+** Display the parameter stack (code for "f.s")
+** f.s ( -- )
+**************************************************************************/
+static void displayFStack(FICL_VM *pVM)
+{+ int d = stackDepth(pVM->fStack);
+ int i;
+ CELL *pCell;
+
+ vmCheckFStack(pVM, 0, 0);
+
+ vmTextOut(pVM, "F:", 0);
+
+ if (d == 0)
+ vmTextOut(pVM, "[0]", 0);
+ else
+ {+ ltoa(d, &pVM->pad[1], pVM->base);
+ pVM->pad[0] = '[';
+ strcat(pVM->pad,"] ");
+ vmTextOut(pVM,pVM->pad,0);
+
+ pCell = pVM->fStack->sp - d;
+ for (i = 0; i < d; i++)
+ {+ sprintf(pVM->pad,"%#f ",(*pCell++).f);
+ vmTextOut(pVM,pVM->pad,0);
+ }
+ }
+}
+
+/*******************************************************************
+** Do float stack depth.
+** fdepth ( -- n )
+*******************************************************************/
+static void Fdepth(FICL_VM *pVM)
+{+ int i;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ i = stackDepth(pVM->fStack);
+ PUSHINT(i);
+}
+
+/*******************************************************************
+** Do float stack drop.
+** fdrop ( r -- )
+*******************************************************************/
+static void Fdrop(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ DROPF(1);
+}
+
+/*******************************************************************
+** Do float stack 2drop.
+** f2drop ( r r -- )
+*******************************************************************/
+static void FtwoDrop(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 0);
+#endif
+
+ DROPF(2);
+}
+
+/*******************************************************************
+** Do float stack dup.
+** fdup ( r -- r r )
+*******************************************************************/
+static void Fdup(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 2);
+#endif
+
+ PICKF(0);
+}
+
+/*******************************************************************
+** Do float stack 2dup.
+** f2dup ( r1 r2 -- r1 r2 r1 r2 )
+*******************************************************************/
+static void FtwoDup(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 4);
+#endif
+
+ PICKF(1);
+ PICKF(1);
+}
+
+/*******************************************************************
+** Do float stack over.
+** fover ( r1 r2 -- r1 r2 r1 )
+*******************************************************************/
+static void Fover(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 3);
+#endif
+
+ PICKF(1);
+}
+
+/*******************************************************************
+** Do float stack 2over.
+** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 )
+*******************************************************************/
+static void FtwoOver(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 4, 6);
+#endif
+
+ PICKF(3);
+ PICKF(3);
+}
+
+/*******************************************************************
+** Do float stack pick.
+** fpick ( n -- r )
+*******************************************************************/
+static void Fpick(FICL_VM *pVM)
+{+ CELL c = POP();
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, c.i+1, c.i+2);
+#endif
+
+ PICKF(c.i);
+}
+
+/*******************************************************************
+** Do float stack ?dup.
+** f?dup ( r -- r )
+*******************************************************************/
+static void FquestionDup(FICL_VM *pVM)
+{+ CELL c;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 2);
+#endif
+
+ c = GETTOPF();
+ if (c.f != 0)
+ PICKF(0);
+}
+
+/*******************************************************************
+** Do float stack roll.
+** froll ( n -- )
+*******************************************************************/
+static void Froll(FICL_VM *pVM)
+{+ int i = POP().i;
+ i = (i > 0) ? i : 0;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, i+1, i+1);
+#endif
+
+ ROLLF(i);
+}
+
+/*******************************************************************
+** Do float stack -roll.
+** f-roll ( n -- )
+*******************************************************************/
+static void FminusRoll(FICL_VM *pVM)
+{+ int i = POP().i;
+ i = (i > 0) ? i : 0;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, i+1, i+1);
+#endif
+
+ ROLLF(-i);
+}
+
+/*******************************************************************
+** Do float stack rot.
+** frot ( r1 r2 r3 -- r2 r3 r1 )
+*******************************************************************/
+static void Frot(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 3, 3);
+#endif
+
+ ROLLF(2);
+}
+
+/*******************************************************************
+** Do float stack -rot.
+** f-rot ( r1 r2 r3 -- r3 r1 r2 )
+*******************************************************************/
+static void Fminusrot(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 3, 3);
+#endif
+
+ ROLLF(-2);
+}
+
+/*******************************************************************
+** Do float stack swap.
+** fswap ( r1 r2 -- r2 r1 )
+*******************************************************************/
+static void Fswap(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 2);
+#endif
+
+ ROLLF(1);
+}
+
+/*******************************************************************
+** Do float stack 2swap
+** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 )
+*******************************************************************/
+static void FtwoSwap(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 4, 4);
+#endif
+
+ ROLLF(3);
+ ROLLF(3);
+}
+
+/*******************************************************************
+** Get a floating point number from a variable.
+** f@ ( n -- r )
+*******************************************************************/
+static void Ffetch(FICL_VM *pVM)
+{+ CELL *pCell;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 0, 1);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ pCell = (CELL *)POPPTR();
+ PUSHFLOAT(pCell->f);
+}
+
+/*******************************************************************
+** Store a floating point number into a variable.
+** f! ( r n -- )
+*******************************************************************/
+static void Fstore(FICL_VM *pVM)
+{+ CELL *pCell;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+ vmCheckStack(pVM, 1, 0);
+#endif
+
+ pCell = (CELL *)POPPTR();
+ pCell->f = POPFLOAT();
+}
+
+/*******************************************************************
+** Add a floating point number to contents of a variable.
+** f+! ( r n -- )
+*******************************************************************/
+static void FplusStore(FICL_VM *pVM)
+{+ CELL *pCell;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 1, 0);
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ pCell = (CELL *)POPPTR();
+ pCell->f += POPFLOAT();
+}
+
+/*******************************************************************
+** Floating point literal execution word.
+*******************************************************************/
+static void fliteralParen(FICL_VM *pVM)
+{+#if FICL_ROBUST > 1
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ PUSHFLOAT(*(float*)(pVM->ip));
+ vmBranchRelative(pVM, 1);
+}
+
+/*******************************************************************
+** Compile a floating point literal.
+*******************************************************************/
+static void fliteralIm(FICL_VM *pVM)
+{+ FICL_DICT *dp = ficlGetDict();
+ FICL_WORD *pfLitParen = ficlLookup("(fliteral)");+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+#endif
+
+ dictAppendCell(dp, LVALUEtoCELL(pfLitParen));
+ dictAppendCell(dp, stackPop(pVM->fStack));
+}
+
+/*******************************************************************
+** Do float 0= comparison r = 0.0.
+** f0= ( r -- T/F )
+*******************************************************************/
+static void FzeroEquals(FICL_VM *pVM)
+{+ CELL c;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
+ vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
+#endif
+
+ c.i = FICL_BOOL(POPFLOAT() == 0);
+ PUSH(c);
+}
+
+/*******************************************************************
+** Do float 0< comparison r < 0.0.
+** f0< ( r -- T/F )
+*******************************************************************/
+static void FzeroLess(FICL_VM *pVM)
+{+ CELL c;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */
+ vmCheckStack(pVM, 0, 1); /* Make sure room for result. */
+#endif
+
+ c.i = FICL_BOOL(POPFLOAT() < 0);
+ PUSH(c);
+}
+
+/*******************************************************************
+** Do float 0> comparison r > 0.0.
+** f0> ( r -- T/F )
+*******************************************************************/
+static void FzeroGreater(FICL_VM *pVM)
+{+ CELL c;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 1, 0);
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ c.i = FICL_BOOL(POPFLOAT() > 0);
+ PUSH(c);
+}
+
+/*******************************************************************
+** Do float = comparison r1 = r2.
+** f= ( r1 r2 -- T/F )
+*******************************************************************/
+static void FisEqual(FICL_VM *pVM)
+{+ float x, y;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 0);
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ x = POPFLOAT();
+ y = POPFLOAT();
+ PUSHINT(FICL_BOOL(x == y));
+}
+
+/*******************************************************************
+** Do float < comparison r1 < r2.
+** f< ( r1 r2 -- T/F )
+*******************************************************************/
+static void FisLess(FICL_VM *pVM)
+{+ float x, y;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 0);
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ y = POPFLOAT();
+ x = POPFLOAT();
+ PUSHINT(FICL_BOOL(x < y));
+}
+
+/*******************************************************************
+** Do float > comparison r1 > r2.
+** f> ( r1 r2 -- T/F )
+*******************************************************************/
+static void FisGreater(FICL_VM *pVM)
+{+ float x, y;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 2, 0);
+ vmCheckStack(pVM, 0, 1);
+#endif
+
+ y = POPFLOAT();
+ x = POPFLOAT();
+ PUSHINT(FICL_BOOL(x > y));
+}
+
+
+#define NUMISNEG 1
+#define EXPISNEG 2
+
+
+/**************************************************************************
+ F l o a t P a r s e S t a t e
+** Enum to determine the current segement of a floating point number
+** being parsed.
+**************************************************************************/
+enum
+{+ FPS_START,
+ FPS_ININT,
+ FPS_INMANT,
+ FPS_STARTEXP,
+ FPS_INEXP
+} FloatParseState;
+
+/**************************************************************************
+ f i c l P a r s e F l o a t N u m b e r
+** pVM -- Virtual Machine pointer.
+** si -- String to parse.
+** Returns 1 if successful, 0 if not.
+**************************************************************************/
+int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si )
+{+ unsigned char ch, digit;
+ char *cp;
+ FICL_COUNT count;
+ float power;
+ float accum = 0.0f;
+ float mant = 0.1f;
+ FICL_INT exponent = 0;
+ char flag = 0;
+ enum FloatParseState estate = FPS_START;
+
+#if FICL_ROBUST > 1
+ vmCheckFStack(pVM, 0, 1);
+#endif
+
+ /*
+ ** floating point numbers only allowed in base 10
+ */
+ if (pVM->base != 10)
+ return(0);
+
+
+ cp = SI_PTR(si);
+ count = (FICL_COUNT)SI_COUNT(si);
+
+ /* Loop through the string's characters. */
+ while ((count--) && ((ch = *cp++) != 0))
+ {+ switch (estate)
+ {+ /* At start of the number so look for a sign. */
+ case FPS_START:
+ {+ estate = FPS_ININT;
+ if (ch == '-')
+ {+ flag |= NUMISNEG;
+ break;
+ }
+ if (ch == '+')
+ {+ break;
+ }
+ } /* Note! Drop through to FPS_ININT */
+ /*
+ **Converting integer part of number.
+ ** Only allow digits, decimal and 'E'.
+ */
+ case FPS_ININT:
+ {+ if (ch == '.')
+ {+ estate = FPS_INMANT;
+ }
+ else if ((ch == 'e') || (ch == 'E'))
+ {+ estate = FPS_STARTEXP;
+ }
+ else
+ {+ digit = (unsigned char)(ch - '0');
+ if ((digit > 9) || (digit < 0))
+ return(0);
+
+ accum = accum * 10 + digit;
+
+ }
+ break;
+ }
+ /*
+ ** Processing the fraction part of number.
+ ** Only allow digits and 'E'
+ */
+ case FPS_INMANT:
+ {+ if ((ch == 'e') || (ch == 'E'))
+ {+ estate = FPS_STARTEXP;
+ }
+ else
+ {+ digit = (unsigned char)(ch - '0');
+ if ((digit > 9) || (digit < 0))
+ return(0);
+
+ accum += digit * mant;
+ mant *= 0.1f;
+ }
+ break;
+ }
+ /* Start processing the exponent part of number. */
+ /* Look for sign. */
+ case FPS_STARTEXP:
+ {+ estate = FPS_INEXP;
+
+ if (ch == '-')
+ {+ flag |= EXPISNEG;
+ break;
+ }
+ else if (ch == '+')
+ {+ break;
+ }
+ } /* Note! Drop through to FPS_INEXP */
+ /*
+ ** Processing the exponent part of number.
+ ** Only allow digits.
+ */
+ case FPS_INEXP:
+ {+ digit = (unsigned char)(ch - '0');
+ if ((digit > 9) || (digit < 0))
+ return(0);
+
+ exponent = exponent * 10 + digit;
+
+ break;
+ }
+ }
+ }
+
+ /* If parser never made it to the exponent this is not a float. */
+ if (estate < FPS_STARTEXP)
+ return(0);
+
+ /* Set the sign of the number. */
+ if (flag & NUMISNEG)
+ accum = -accum;
+
+ /* If exponent is not 0 then adjust number by it. */
+ if (exponent != 0)
+ {+ /* Determine if exponent is negative. */
+ if (flag & EXPISNEG)
+ {+ exponent = -exponent;
+ }
+ /* power = 10^x */
+ power = (float)pow(10.0, exponent);
+ accum *= power;
+ }
+
+ PUSHFLOAT(accum);
+
+ return(1);
+}
+
+#endif /* FICL_WANT_FLOAT */
+
+/**************************************************************************
+** Add float words to a system's dictionary.
+** pSys -- Pointer to the FICL sytem to add float words to.
+**************************************************************************/
+void ficlCompileFloat(FICL_SYSTEM *pSys)
+{+ FICL_DICT *dp = pSys->dp;
+ assert(dp);
+
+#if FICL_WANT_FLOAT
+ dictAppendWord(dp, "f!", Fstore, FW_DEFAULT);
+ dictAppendWord(dp, "f?dup", FquestionDup, FW_DEFAULT);
+ dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT);
+ dictAppendWord(dp, "f=", FisEqual, FW_DEFAULT);
+ dictAppendWord(dp, "f<", FisLess, FW_DEFAULT);
+ dictAppendWord(dp, "f>", FisGreater, FW_DEFAULT);
+ dictAppendWord(dp, "f0=", FzeroEquals, FW_DEFAULT);
+ dictAppendWord(dp, "f0<", FzeroLess, FW_DEFAULT);
+ dictAppendWord(dp, "f0>", FzeroGreater, FW_DEFAULT);
+ dictAppendWord(dp, "f2drop", FtwoDrop, FW_DEFAULT);
+ dictAppendWord(dp, "f2dup", FtwoDup, FW_DEFAULT);
+ dictAppendWord(dp, "f2over", FtwoOver, FW_DEFAULT);
+ dictAppendWord(dp, "f2swap", FtwoSwap, FW_DEFAULT);
+ dictAppendWord(dp, "f+", Fadd, FW_DEFAULT);
+ dictAppendWord(dp, "f+!", FplusStore, FW_DEFAULT);
+ dictAppendWord(dp, "f-", Fsub, FW_DEFAULT);
+ dictAppendWord(dp, "f*", Fmul, FW_DEFAULT);
+ dictAppendWord(dp, "f/", Fdiv, FW_DEFAULT);
+ dictAppendWord(dp, "f+i", Faddi, FW_DEFAULT);
+ dictAppendWord(dp, "f-i", Fsubi, FW_DEFAULT);
+ dictAppendWord(dp, "f*i", Fmuli, FW_DEFAULT);
+ dictAppendWord(dp, "f/i", Fdivi, FW_DEFAULT);
+ dictAppendWord(dp, "fconstant", Fconstant, FW_DEFAULT);
+ dictAppendWord(dp, "fdepth", Fdepth, FW_DEFAULT);
+ dictAppendWord(dp, "fdrop", Fdrop, FW_DEFAULT);
+ dictAppendWord(dp, "fdup", Fdup, FW_DEFAULT);
+ dictAppendWord(dp, "fliteral", fliteralIm, FW_IMMEDIATE);
+ dictAppendWord(dp, "int>float", itof, FW_DEFAULT);
+ dictAppendWord(dp, "float>int", Ftoi, FW_DEFAULT);
+ dictAppendWord(dp, "f.", FDot, FW_DEFAULT);
+ dictAppendWord(dp, "f.s", displayFStack, FW_DEFAULT);
+ dictAppendWord(dp, "fe.", EDot, FW_DEFAULT);
+ dictAppendWord(dp, "fover", Fover, FW_DEFAULT);
+ dictAppendWord(dp, "fnegate", Fnegate, FW_DEFAULT);
+ dictAppendWord(dp, "fpick", Fpick, FW_DEFAULT);
+ dictAppendWord(dp, "froll", Froll, FW_DEFAULT);
+ dictAppendWord(dp, "frot", Frot, FW_DEFAULT);
+ dictAppendWord(dp, "fswap", Fswap, FW_DEFAULT);
+ dictAppendWord(dp, "i-f", isubf, FW_DEFAULT);
+ dictAppendWord(dp, "i/f", idivf, FW_DEFAULT);
+
+ dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT);
+ dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT);
+ dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);
+
+ ficlSetEnv("floating", FICL_FALSE); /* not all required words are present */+ ficlSetEnv("floating-ext", FICL_FALSE);+ ficlSetEnv("floating-stack", FICL_DEFAULT_STACK);+
+ ficlAddPrecompiledParseStep(pSys, "fnumber?", ficlParseFloatNumber);
+#endif
+ return;
+}
\ No newline at end of file
--- /dev/null
+++ b/prefix.c
@@ -1,0 +1,182 @@
+/*******************************************************************
+** p r e f i x . c
+** Forth Inspired Command Language
+** Parser extensions for Ficl
+** Authors: Larry Hastings & John Sadler (john_sadler@alum.mit.edu)
+** Created: April 2001
+** $Id: prefix.c,v 1.0 2001/04/25 18:39:00 jsadler Exp $
+*******************************************************************/
+/*
+** Get the latest Ficl release at http://ficl.sourceforge.net
+**
+** L I C E N S E and D I S C L A I M E R
+**
+** Ficl is free software; you can redistribute it and/or
+** modify it under the terms of the GNU Lesser General Public
+** License as published by the Free Software Foundation; either
+** version 2.1 of the License, or (at your option) any later version.
+**
+** The ficl software code is provided on an "as is" basis without
+** warranty of any kind, including, without limitation, the implied
+** warranties of merchantability and fitness for a particular purpose
+** and their equivalents under the laws of any jurisdiction.
+** See the GNU Lesser General Public License for more details.
+**
+** To view the GNU Lesser General Public License, visit this URL:
+** http://www.fsf.org/copyleft/lesser.html
+**
+** Any third party may reproduce, distribute, or modify the ficl
+** software code or any derivative works thereof without any
+** compensation or license, provided that the author information
+** and this license text are retained in the source code files.
+**
+** I am interested in hearing from anyone who uses ficl. If you have
+** a problem, a success story, a defect, an enhancement request, or
+** if you would like to contribute to the ficl release (yay!), please
+** send me email at the address above.
+*/
+
+#include <string.h>
+#include <ctype.h>
+#include "ficl.h"
+#include "math64.h"
+
+/*
+** (jws) revisions:
+** A prefix is a word in a dedicated wordlist (name stored in list_name below)
+** that is searched in a special way by the prefix parse step. When a prefix
+** matches the beginning of an incoming token, push the non-prefix part of the
+** token back onto the input stream and execute the prefix code.
+**
+** The parse step is called ficlParsePrefix.
+** Storing prefix entries in the dictionary greatly simplifies
+** the process of matching and dispatching prefixes, avoids the
+** need to clean up a dynamically allocated prefix list when the system
+** goes away, but still allows prefixes to be allocated at runtime.
+*/
+
+static char list_name[] = "<prefixes>";
+
+/**************************************************************************
+ f i c l P a r s e P r e f i x
+** This is the parse step for prefixes - it checks an incoming word
+** to see if it starts with a prefix, and if so runs the corrseponding
+** code against the remainder of the word and returns true.
+**************************************************************************/
+int ficlParsePrefix(FICL_VM *pVM, STRINGINFO si)
+{+ int i;
+ FICL_HASH *pHash;
+ FICL_WORD *pFW = ficlLookup(list_name);
+
+ assert(pFW);
+ pHash = (FICL_HASH *)(pFW->param[0].p);
+ /*
+ ** Walk the list looking for a match with the beginning of the incoming token
+ */
+ for (i = 0; i < (int)pHash->size; i++)
+ {+ pFW = pHash->table[i];
+ while (pFW != NULL)
+ {+ int n;
+ n = pFW->nName;
+ /*
+ ** If we find a match, adjust the TIB to give back the non-prefix characters
+ ** and execute the prefix word.
+ */
+ if (!strincmp(SI_PTR(si), pFW->name, (FICL_UNS)n))
+ {+ vmSetTibIndex(pVM, vmGetTibIndex(pVM) - 1 - SI_COUNT(si) + n);
+ vmExecute(pVM, pFW);
+
+ return FICL_TRUE;
+ }
+ pFW = pFW->link;
+ }
+ }
+
+ return FICL_FALSE;
+}
+
+
+static void tempBase(FICL_VM *pVM, int base)
+{+ int oldbase = pVM->base;
+ STRINGINFO si = vmGetWord0(pVM);
+
+ pVM->base = base;
+ if (!ficlParseNumber(pVM, si))
+ {+ int i = SI_COUNT(si);
+ vmThrowErr(pVM, "0x%.*s is not a valid hex value", i, SI_PTR(si));
+ }
+
+ pVM->base = oldbase;
+ return;
+}
+
+static void fTempBase(FICL_VM *pVM)
+{+ int base = stackPopINT(pVM->pStack);
+ tempBase(pVM, base);
+ return;
+}
+
+static void prefixHex(FICL_VM *pVM)
+{+ tempBase(pVM, 16);
+}
+
+static void prefixTen(FICL_VM *pVM)
+{+ tempBase(pVM, 10);
+}
+
+
+/**************************************************************************
+ f i c l C o m p i l e P r e f i x
+** Build prefix support into the dictionary and the parser
+** Note: since prefixes always execute, they are effectively IMMEDIATE.
+** If they need to generate code in compile state you must add
+** this code explicitly.
+**************************************************************************/
+void ficlCompilePrefix(FICL_SYSTEM *pSys)
+{+ FICL_DICT *dp = pSys->dp;
+ FICL_HASH *pHash;
+ FICL_HASH *pPrevCompile = dp->pCompile;
+#if (FICL_EXTENDED_PREFIX)
+ FICL_WORD *pFW;
+#endif
+
+ /*
+ ** Create a named wordlist for prefixes to reside in...
+ ** Since we're doing a special kind of search, make it
+ ** a single bucket hashtable - hashing does not help here.
+ */
+ pHash = dictCreateWordlist(dp, 1);
+ pHash->name = list_name;
+ dictAppendWord(dp, list_name, constantParen, FW_DEFAULT);
+ dictAppendCell(dp, LVALUEtoCELL(pHash));
+ dictAppendWord(dp, "__tempbase", fTempBase, FW_DEFAULT);
+
+ /*
+ ** Temporarily make the prefix list the compile wordlist so that
+ ** we can create some precompiled prefixes.
+ */
+ dp->pCompile = pHash;
+ dictAppendWord(dp, "0x", prefixHex, FW_DEFAULT);
+ dictAppendWord(dp, "0d", prefixTen, FW_DEFAULT);
+#if (FICL_EXTENDED_PREFIX)
+ pFW = ficlLookup("\\");+ if (pFW)
+ {+ dictAppendWord(dp, "//", pFW->code, FW_DEFAULT);
+ }
+#endif
+ dp->pCompile = pPrevCompile;
+
+ ficlAddPrecompiledParseStep(pSys, "prefix?", ficlParsePrefix);
+ return;
+}
--- /dev/null
+++ b/win32.c
@@ -1,0 +1,314 @@
+/*
+ * win32.c
+ * submitted to Ficl by Larry Hastings, larry@hastings.org
+ * Additional Win32 words by Guy Carver
+ *
+ * adds calling arbitrary DLL function calls from inside Ficl.
+ *
+ * note that Microsoft's own header files won't compile without
+ * "language extensions" (anonymous structs/unions) turned on.
+ * and even with that, it still gives a warning in rpcasync.h
+ * for something that compiles clean in C++. I turned it off.
+ *
+ */
+#pragma warning(disable : 4115)
+#include <stdio.h>
+#include <windows.h>
+#include <string.h>
+#include <direct.h>
+
+#include "ficl.h"
+
+static void loadLibrary(FICL_VM *pVM) /* ( address length -- hmodule ) */
+{+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *buf = (char *)_alloca(length + 1);
+ memcpy(buf, address, length);
+ buf[length] = 0;
+
+ stackPushINT(pVM->pStack, (int)LoadLibrary(buf));
+}
+
+static void getProcAddress(FICL_VM *pVM) /* ( address length hmodule -- ) */
+{+ HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack);
+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *buf = (char *)_alloca(length + 1);
+ memcpy(buf, address, length);
+ buf[length] = 0;
+
+ stackPushINT(pVM->pStack, (int)GetProcAddress(hModule, buf));
+}
+
+
+static void freeLibrary(FICL_VM *pVM) /* ( hmodule -- ) */
+{+ HMODULE hModule = (HMODULE)stackPopINT(pVM->pStack);
+ FreeLibrary(hModule);
+}
+
+
+static void uAddrToCString(FICL_VM *pVM) /* ( address length -- c-string ) */
+{+ int length = stackPopINT(pVM->pStack);
+ void *address = (void *)stackPopPtr(pVM->pStack);
+
+ char *buf = (char *)malloc(length + 1);
+ memcpy(buf, address, length);
+ buf[length] = 0;
+ stackPushPtr(pVM->pStack, buf);
+ return;
+}
+
+
+static void callNativeFunction(FICL_VM *pVM) /* ( ... argcount fnaddress popstack -- returnvalue ) */
+{+ int popstack = stackPopINT(pVM->pStack);
+ int fnaddress = stackPopINT(pVM->pStack);
+ int argcount = stackPopINT(pVM->pStack);
+ int returnvalue;
+
+ int i;
+ for (i = 0; i < argcount; i++)
+ {+ int nextarg = stackPopINT(pVM->pStack);
+ __asm
+ {+ mov eax, nextarg
+ push eax
+ }
+ }
+
+
+ __asm
+ {+ call fnaddress
+ mov returnvalue, eax
+ }
+
+ /*
+ * if popstack is nonzero,
+ * the arguments are popped off the stack after calling
+ */
+ if (popstack)
+ {+ argcount *= 4;
+ __asm add esp, argcount
+ }
+ stackPushINT(pVM->pStack, returnvalue);
+ return;
+}
+
+
+/**************************************************************************
+ v c a l l
+** Call a class method. (Contributed by Guy Carver)
+** FORTH: (params inst paramcnt vtableindex -- res )
+** INFO: paramcnt has msb set if return value is desired.
+**************************************************************************/
+static void VCall(FICL_VM *pVM)
+{+ int ind,p,paramCnt;
+ void *instance;
+ int I;
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,3,1);
+#endif
+
+ ind = POPINT() * 4;
+ paramCnt = POPINT();
+ instance = POPPTR(); //Get instance of class.
+
+ __asm push ecx //Save ecx.
+ __asm push esp //Save stack.
+
+ I = paramCnt & 0xFF; //Strip off any flags.
+
+#if FICL_ROBUST > 1
+ vmCheckStack(pVM,I,0);
+#endif
+
+ while(I--) //Loop for parameter count.
+ {+ p = POPINT();
+ __asm
+ {+ mov eax,p
+ push eax //Push on stack.
+ }
+ }
+ __asm
+ {+ mov ecx,instance //Set ecx to instance.
+ mov eax,[ecx] //Get method pointer.
+ add eax,ind
+ call [eax] //Call method.
+ mov p,eax //Put result in p.
+ pop esp
+ pop ecx //Restore ecx and esp.
+ }
+ if (paramCnt & 0x80000000) //If supposed to return a result.
+ PUSHINT(p); //Store result.
+}
+
+
+//**************************************************************
+//Load forth file.
+//ENTER: pVM = Pointer to forth virtual machine.
+//FORTH: ( -<FileName>- )
+//**************************************************************
+static void ForthLoad(FICL_VM *pVM)
+{+ char cp[256];
+ char fileName[256];
+ FILE *fp;
+ int result = 0;
+ CELL id;
+ int nLine = 0;
+ FICL_STRING *pFileName = (FICL_STRING *)fileName;
+
+ vmGetString(pVM,pFileName, ' ');
+
+ if (pFileName->count <= 0)
+ {+ vmTextOut(pVM,"Type fload filename", 1);
+ return;
+ }
+
+ fp = fopen(pFileName->text, "r");
+ if (fp)
+ {+ id = pVM->sourceID;
+ pVM->sourceID.p = (void *)fp; //Set input source id.
+
+ while (fgets(cp,256,fp)) //Read line.
+ {+ int len = strlen(cp) - 1; //Get length.
+
+ nLine++; //Inc line count.
+ if (len > 0) //if length.
+ {+ cp[len] = 0; //Make sure null terminated.
+ result = ficlExec(pVM,cp); //Execute line.
+ if ((result == VM_ERREXIT) //If exit.
+ || (result == VM_USEREXIT)
+ || (result == VM_QUIT))
+ {+ pVM->sourceID = id;
+ fclose(fp);
+ vmThrowErr(pVM, "Error loading file <%s> line %d", pFileName->text, nLine);
+ break;
+ }
+ }
+ }
+ pVM->sourceID.i = -1;
+ ficlExec(pVM,""); //Empty line to flush any pending refills.
+ pVM->sourceID = id; //Reset source ID.
+ fclose(fp);
+ if (result == VM_USEREXIT) //If user exit.
+ vmThrow(pVM,VM_USEREXIT); //Resend user exit code.
+ }
+ else
+ {+ vmTextOut(pVM,"Unable to open file: ", 0);
+ vmTextOut(pVM, pFileName->text,1);
+ }
+}
+
+//********************************************************************************
+//
+//********************************************************************************
+static STRINGINFO parseFileName(FICL_VM *pVM)
+{+ STRINGINFO si;
+ char *pSrc = vmGetInBuf(pVM);
+ si.cp = pSrc; /* mark start of text */
+ while ((*pSrc != ' ') && (*pSrc != 0) && (*pSrc != '\n'))
+ {+ if (*(pSrc++) == '\\') /* find next delimiter or end */
+ si.cp = pSrc;
+ }
+ si.count = pSrc - si.cp; /* set length of result */
+ return(si);
+}
+
+//********************************************************************************
+//check for included file and load if not loaded.
+//********************************************************************************
+static void include(FICL_VM *pVM)
+{+ STRINGINFO si;
+ FICL_WORD *pFW;
+ FICL_DICT *dp = ficlGetDict();
+ FICL_CODE pCreateParen = ficlLookup("(create)")->code;+
+ si = parseFileName(pVM);
+
+ if (si.count)
+ {+ pFW = dictLookup(dp, si);
+ if (!pFW) //Forget word.
+ {+ dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT);
+ dictAllotCells(dp, 1);
+ ForthLoad(pVM);
+ }
+ }
+}
+
+//********************************************************************************
+//check for included file and kill it if its included to reload.
+//********************************************************************************
+static void reinclude(FICL_VM *pVM)
+{+ STRINGINFO si;
+ FICL_WORD *pFW;
+ FICL_DICT *dp = ficlGetDict();
+ FICL_CODE pCreateParen = ficlLookup("(create)")->code;+
+ si = parseFileName(pVM);
+
+ if (si.count)
+ {+ pFW = dictLookup(dp, si);
+ if (pFW) //Forget word.
+ {+ hashForget(dp->pCompile,pFW->name);
+ dp->here = PTRtoCELL (pFW->name);
+ }
+
+ dictAppendWord2(dp, si, pCreateParen, FW_DEFAULT);
+ dictAllotCells(dp, 1);
+ ForthLoad(pVM);
+ }
+}
+
+
+/**************************************************************************
+ f i c l C o m p i l e P l a t f o r m
+** Build Win32 platform extensions into the system dictionary
+**************************************************************************/
+void ficlCompilePlatform(FICL_SYSTEM *pSys)
+{+ FICL_DICT *dp = pSys->dp;
+ assert (dp);
+
+ dictAppendWord(dp, "loadlibrary", loadLibrary, FW_DEFAULT);
+ dictAppendWord(dp, "getprocaddress", getProcAddress, FW_DEFAULT);
+ dictAppendWord(dp, "freelibrary", freeLibrary, FW_DEFAULT);
+ dictAppendWord(dp, "uaddr->cstring", uAddrToCString, FW_DEFAULT);
+ dictAppendWord(dp, "callnativefunction",
+ callNativeFunction,
+ FW_DEFAULT);
+ dictAppendWord(dp, "vcall", VCall, FW_DEFAULT);
+ dictAppendWord(dp, "include", include, FW_DEFAULT);
+ dictAppendWord(dp, "reinclude", reinclude, FW_DEFAULT);
+
+ return;
+}
+