d/freebsd-nq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
6cc4520b0a
freebsd-nq/stand/ficl/float.c

1068 lines
27 KiB
C
Raw Normal View History

Upgrade to FICL version 3.02. Anything wrong is my fault, everything right is due Jon Mini. PR: 36308 Submitted by: Jon Mini <mini@haikugeek.com> MFC after: 4 weeks
2002-04-09 17:45:28 +00:00
/*******************************************************************
** 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$ */
Revert r326855: Cargo cut a fix for the regressions r326585 caused. This was an experiment that landed in the wrong branch and was pushed accidentally. It's best if it is ignored because the difference was due to vers.o being different, not float.o... And it was confirmed to not fix anything... Pointy Hat to: imp
2017-12-14 18:57:17 +00:00
#include "ficl.h"
#if FICL_WANT_FLOAT
Upgrade to FICL version 3.02. Anything wrong is my fault, everything right is due Jon Mini. PR: 36308 Submitted by: Jon Mini <mini@haikugeek.com> MFC after: 4 weeks
2002-04-09 17:45:28 +00:00
#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 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);
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
if (pVM->state == COMPILE)
fliteralIm(pVM);
Upgrade to FICL version 3.02. Anything wrong is my fault, everything right is due Jon Mini. PR: 36308 Submitted by: Jon Mini <mini@haikugeek.com> MFC after: 4 weeks
2002-04-09 17:45:28 +00:00
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;
}
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
Reference in New Issue Copy Permalink