d/freebsd-skq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
879da4fe23
freebsd-skq/sys/boot/ficl/float.c
jkim ade9ba91cb Update to FICL 3.03 (the last release before FICL4 rewrite). 
The relevant changes for FreeBSD (excerpt from the release note):

  * Newly implemented CORE EXT words: CASE, OF, ENDOF, and ENDCASE. Also
    added FALLTHROUGH, which works like ENDOF but jumps to the instruction
    just after the next OF.
  * Bugfix: John-Hopkins locals syntax now accepts | and -- in the comment
    (between the first -- and the }.)
  * Bugfix: Changed vmGetWord0() to make Purify happier. The resulting
    code is no slower, no larger, and slightly more robust.
2007-03-23 22:26:01 +00:00

1068 lines
27 KiB
C
Raw Blame History

/*******************************************************************
** 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.8 2001/12/05 07:21:34 jsadler Exp $
*******************************************************************/
/*
** Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu)
** 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.
*/
/* $FreeBSD$ */
#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)
{
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 segement 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;
}
Reference in New Issue View Git Blame Copy Permalink