float.c

/*******************************************************************
** f l o a t . c
** Forth Inspired Command Language
** ANS Forth FLOAT word-set written in C
** Author: Guy Carver & John Sadler ([email protected])
** Created: Apr 2001
** $Id: float.c,v 1.8 2001/12/05 07:21:34 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler ([email protected])
** All rights reserved.
**
** Get the latest Ficl release at http://ficl.sourceforge.net
**
** 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, please
** contact me by email at the address above.
**
** L I C E N S E  and  D I S C L A I M E R
** 
** Redistribution and use in source and binary forms, with or without
** modification, are permitted provided that the following conditions
** are met:
** 1. Redistributions of source code must retain the above copyright
**    notice, this list of conditions and the following disclaimer.
** 2. Redistributions in binary form must reproduce the above copyright
**    notice, this list of conditions and the following disclaimer in the
**    documentation and/or other materials provided with the distribution.
**
** THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
** ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
** IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
** ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
** FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
** DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
** OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
** LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
** OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
** SUCH DAMAGE.
*/


#include "ficl.h"

#if FICL_WANT_FLOAT
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include <math.h>

/*******************************************************************
** Do float addition r1 + r2.
** f+ ( r1 r2 -- r )
*******************************************************************/
static void Fadd(FICL_VM *pVM)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 2, 1);
#endif

    f = POPFLOAT();
    f += GETTOPF().f;
    SETTOPF(f);
}

/*******************************************************************
** Do float subtraction r1 - r2.
** f- ( r1 r2 -- r )
*******************************************************************/
static void Fsub(FICL_VM *pVM)
{
    FICL_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)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 2, 1);
#endif

    f = POPFLOAT();
    f *= GETTOPF().f;
    SETTOPF(f);
}

/*******************************************************************
** Do float negation.
** fnegate ( r -- r )
*******************************************************************/
static void Fnegate(FICL_VM *pVM)
{
    FICL_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)
{
    FICL_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)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1, 1);
    vmCheckStack(pVM, 1, 0);
#endif

    f = (FICL_FLOAT)POPINT();
    f += GETTOPF().f;
    SETTOPF(f);
}

/*******************************************************************
** Do float - integer r - n.
** f-i ( r n -- r )
*******************************************************************/
static void Fsubi(FICL_VM *pVM)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1, 1);
    vmCheckStack(pVM, 1, 0);
#endif

    f = GETTOPF().f;
    f -= (FICL_FLOAT)POPINT();
    SETTOPF(f);
}

/*******************************************************************
** Do float * integer r * n.
** f*i ( r n -- r )
*******************************************************************/
static void Fmuli(FICL_VM *pVM)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1, 1);
    vmCheckStack(pVM, 1, 0);
#endif

    f = (FICL_FLOAT)POPINT();
    f *= GETTOPF().f;
    SETTOPF(f);
}

/*******************************************************************
** Do float / integer r / n.
** f/i ( r n -- r )
*******************************************************************/
static void Fdivi(FICL_VM *pVM)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1, 1);
    vmCheckStack(pVM, 1, 0);
#endif

    f = GETTOPF().f;
    f /= (FICL_FLOAT)POPINT();
    SETTOPF(f);
}

/*******************************************************************
** Do integer - float n - r.
** i-f ( n r -- r )
*******************************************************************/
static void isubf(FICL_VM *pVM)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1, 1);
    vmCheckStack(pVM, 1, 0);
#endif

    f = (FICL_FLOAT)POPINT();
    f -= GETTOPF().f;
    SETTOPF(f);
}

/*******************************************************************
** Do integer / float n / r.
** i/f ( n r -- r )
*******************************************************************/
static void idivf(FICL_VM *pVM)
{
    FICL_FLOAT f;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1,1);
    vmCheckStack(pVM, 1, 0);
#endif

    f = (FICL_FLOAT)POPINT();
    f /= 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 = vmGetDict(pVM);
    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 = vmGetDict(pVM);
    FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(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));
}


/*******************************************************************
** Move float to param stack (assumes they both fit in a single CELL)
** f>s 
*******************************************************************/
static void FFrom(FICL_VM *pVM)
{
    CELL c;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 1, 0);
    vmCheckStack(pVM, 0, 1);
#endif

    c = stackPop(pVM->fStack);
    stackPush(pVM->pStack, c);
    return;
}

static void ToF(FICL_VM *pVM)
{
    CELL c;

#if FICL_ROBUST > 1
    vmCheckFStack(pVM, 0, 1);
    vmCheckStack(pVM, 1, 0);
#endif

    c = stackPop(pVM->pStack);
    stackPush(pVM->fStack, c);
    return;
}


/**************************************************************************
                     F l o a t P a r s e S t a t e
** Enum to determine the current segment of a floating point number
** being parsed.
**************************************************************************/
#define NUMISNEG 1
#define EXPISNEG 2

typedef enum _floatParseState
{
    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;
    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)
                        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)
                        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)
                    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);
    if (pVM->state == COMPILE)
        fliteralIm(pVM);

    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, ">float",    ToF,            FW_DEFAULT);
    /* d>f */
    dictAppendWord(dp, "f!",        Fstore,         FW_DEFAULT);
    dictAppendWord(dp, "f*",        Fmul,           FW_DEFAULT);
    dictAppendWord(dp, "f+",        Fadd,           FW_DEFAULT);
    dictAppendWord(dp, "f-",        Fsub,           FW_DEFAULT);
    dictAppendWord(dp, "f/",        Fdiv,           FW_DEFAULT);
    dictAppendWord(dp, "f0<",       FzeroLess,      FW_DEFAULT);
    dictAppendWord(dp, "f0=",       FzeroEquals,    FW_DEFAULT);
    dictAppendWord(dp, "f<",        FisLess,        FW_DEFAULT);
 /* 
    f>d 
 */
    dictAppendWord(dp, "f@",        Ffetch,         FW_DEFAULT);
 /* 
    falign 
    faligned 
 */
    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);
/*
    float+
    floats
    floor
    fmax
    fmin
*/
    dictAppendWord(dp, "f?dup",     FquestionDup,   FW_DEFAULT);
    dictAppendWord(dp, "f=",        FisEqual,       FW_DEFAULT);
    dictAppendWord(dp, "f>",        FisGreater,     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+!",       FplusStore,     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, "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, "float>",    FFrom,          FW_DEFAULT);

    dictAppendWord(dp, "f-roll",    FminusRoll,     FW_DEFAULT);
    dictAppendWord(dp, "f-rot",     Fminusrot,      FW_DEFAULT);
    dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE);

    ficlSetEnv(pSys, "floating",       FICL_FALSE);  /* not all required words are present */
    ficlSetEnv(pSys, "floating-ext",   FICL_FALSE);
    ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK);
#endif
    return;
}