108bcd504e
We need to include ficl.h after the standard includes, rather than before them. It changes the generated code in ways that haven't been completely analyized. This restores the old code generation (as verified by md5 changing back for zfsloader). This should restore GPT + ZFS and GPT + ZFS + GELI booting that was broken in r326585 (or would have been if r326584 hadn't broken the build). Sponsored by: Netflix
1068 lines
27 KiB
C
1068 lines
27 KiB
C
/*******************************************************************
|
|
** 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 "ficl.h"
|
|
|
|
#if FICL_WANT_FLOAT
|
|
#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);
|
|
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;
|
|
}
|
|
|