common/ficl/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 (john_sadler@alum.mit.edu)
 * Created: Apr 2001
 * $Id: float.c,v 1.10 2010/09/13 18:43:04 asau 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.
 */

#include "ficl.h"

#if FICL_WANT_FLOAT
#include <math.h>
#include <values.h>


/*
 * Create a floating point constant.
 * fconstant ( r -"name"- )
 */
static void
ficlPrimitiveFConstant(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    FICL_STACK_CHECK(vm->floatStack, 1, 0);

    ficlDictionaryAppendWord(dictionary, name,
        (ficlPrimitive)ficlInstructionFConstantParen, FICL_WORD_DEFAULT);
    ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
}


ficlWord *
ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name,
    ficlFloat value)
{
    ficlString s;
    FICL_STRING_SET_FROM_CSTRING(s, name);
    return (ficlDictionaryAppendConstantInstruction(dictionary, s,
        ficlInstructionFConstantParen, *(ficlInteger *)(&value)));
}


ficlWord *
ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name,
    ficlFloat value)
{
    ficlString s;
    FICL_STRING_SET_FROM_CSTRING(s, name);
    return (ficlDictionarySetConstantInstruction(dictionary, s,
        ficlInstructionFConstantParen, *(ficlInteger *)(&value)));
}


static void
ficlPrimitiveF2Constant(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlString name = ficlVmGetWord(vm);

    FICL_STACK_CHECK(vm->floatStack, 2, 0);

    ficlDictionaryAppendWord(dictionary, name,
        (ficlPrimitive)ficlInstructionF2ConstantParen, FICL_WORD_DEFAULT);
    ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
    ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack));
}

ficlWord *
ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name,
    ficlFloat value)
{
    ficlString s;
    FICL_STRING_SET_FROM_CSTRING(s, name);
    return (ficlDictionaryAppend2ConstantInstruction(dictionary, s,
        ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value)));
}

ficlWord *
ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name,
    ficlFloat value)
{
    ficlString s;
    FICL_STRING_SET_FROM_CSTRING(s, name);
    return (ficlDictionarySet2ConstantInstruction(dictionary, s,
        ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value)));
}

/*
 * Display a float in decimal format.
 * f. ( r -- )
 */
static void
ficlPrimitiveFDot(ficlVm *vm)
{
    ficlFloat f;

    FICL_STACK_CHECK(vm->floatStack, 1, 0);

    f = ficlStackPopFloat(vm->floatStack);
    sprintf(vm->pad, "%#f ", f);
    ficlVmTextOut(vm, vm->pad);
}

/*
 * Display a float in engineering format.
 * fe. ( r -- )
 */
static void
ficlPrimitiveEDot(ficlVm *vm)
{
    ficlFloat f;

    FICL_STACK_CHECK(vm->floatStack, 1, 0);

    f = ficlStackPopFloat(vm->floatStack);
    sprintf(vm->pad, "%#e ", f);
    ficlVmTextOut(vm, vm->pad);
}

/*
 * d i s p l a y FS t a c k
 * Display the parameter stack (code for "f.s")
 * f.s ( -- )
 */
struct stackContext
{
    ficlVm *vm;
    int count;
};

static ficlInteger
ficlFloatStackDisplayCallback(void *c, ficlCell *cell)
{
    struct stackContext *context = (struct stackContext *)c;
    char buffer[80];
#ifdef  _LP64
    snprintf(buffer, sizeof (buffer), "[0x%016lx %3d] %20e (0x%016lx)\n",
        (unsigned long) cell, context->count++, cell->f, cell->u);
#else
    snprintf(buffer, sizeof (buffer), "[0x%08x %3d] %12e (0x%08x)\n",
        (unsigned)cell, context->count++, cell->f, cell->u);
#endif
    ficlVmTextOut(context->vm, buffer);
    return (FICL_TRUE);
}

void
ficlVmDisplayFloatStack(ficlVm *vm)
{
    struct stackContext context;
    context.vm = vm;
    context.count = 0;
    ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback,
        &context);
}

/*
 * Do float stack depth.
 * fdepth ( -- n )
 */
static void
ficlPrimitiveFDepth(ficlVm *vm)
{
    int i;

    FICL_STACK_CHECK(vm->dataStack, 0, 1);

    i = ficlStackDepth(vm->floatStack);
    ficlStackPushInteger(vm->dataStack, i);
}

/*
 * Compile a floating point literal.
 */
static void
ficlPrimitiveFLiteralImmediate(ficlVm *vm)
{
    ficlDictionary *dictionary = ficlVmGetDictionary(vm);
    ficlCell cell;

    FICL_STACK_CHECK(vm->floatStack, 1, 0);

    cell = ficlStackPop(vm->floatStack);
    if (cell.f == 1.0f) {
        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1);
    } else if (cell.f == 0.0f) {
        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0);
    } else if (cell.f == -1.0f) {
        ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1);
    } else {
        ficlDictionaryAppendUnsigned(dictionary,
            ficlInstructionFLiteralParen);
        ficlDictionaryAppendCell(dictionary, cell);
    }
}

/*
 * 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
 * vm -- Virtual Machine pointer.
 * s -- String to parse.
 * Returns 1 if successful, 0 if not.
 */
int
ficlVmParseFloatNumber(ficlVm *vm, ficlString s)
{
    unsigned char c;
    unsigned char digit;
    char *trace;
    ficlUnsigned length;
    ficlFloat power;
    ficlFloat accum = 0.0f;
    ficlFloat mant = 0.1f;
    ficlInteger exponent = 0;
    char flag = 0;
    FloatParseState estate = FPS_START;

    FICL_STACK_CHECK(vm->floatStack, 0, 1);

    /*
     * floating point numbers only allowed in base 10
     */
    if (vm->base != 10)
        return (0);

    trace = FICL_STRING_GET_POINTER(s);
    length = FICL_STRING_GET_LENGTH(s);

    /* Loop through the string's characters. */
    while ((length--) && ((c = *trace++) != 0)) {
        switch (estate) {
            /* At start of the number so look for a sign. */
        case FPS_START:
            estate = FPS_ININT;
            if (c == '-') {
                flag |= NUMISNEG;
                break;
            }
            if (c == '+') {
                break;
            }
        /* Note!  Drop through to FPS_ININT */
        /*
         * Converting integer part of number.
         * Only allow digits, decimal and 'E'.
         */
        case FPS_ININT:
            if (c == '.') {
                estate = FPS_INMANT;
            } else if ((c == 'e') || (c == 'E')) {
                estate = FPS_STARTEXP;
            } else {
                digit = (unsigned char)(c - '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 ((c == 'e') || (c == 'E')) {
                estate = FPS_STARTEXP;
            } else {
                digit = (unsigned char)(c - '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 (c == '-') {
                flag |= EXPISNEG;
                break;
            } else if (c == '+') {
                break;
            }
        /* Note!  Drop through to FPS_INEXP */
        /*
         * Processing the exponent part of number.
         * Only allow digits.
         */
        case FPS_INEXP:
            digit = (unsigned char)(c - '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 */
#if defined(_LP64)
        power = (ficlFloat)pow(10.0, exponent);
#else
        power = (ficlFloat)powf(10.0, exponent);
#endif
        accum *= power;
    }

    ficlStackPushFloat(vm->floatStack, accum);
    if (vm->state == FICL_VM_STATE_COMPILE)
        ficlPrimitiveFLiteralImmediate(vm);

    return (1);
}
#endif  /* FICL_WANT_FLOAT */

#if FICL_WANT_LOCALS
static void
ficlPrimitiveFLocalParen(ficlVm *vm)
{
    ficlLocalParen(vm, 0, 1);
}

static void
ficlPrimitiveF2LocalParen(ficlVm *vm)
{
    ficlLocalParen(vm, 1, 1);
}
#endif /* FICL_WANT_LOCALS */

/*
 * Add float words to a system's dictionary.
 * system -- Pointer to the Ficl sytem to add float words to.
 */
void
ficlSystemCompileFloat(ficlSystem *system)
{
    ficlDictionary *dictionary = ficlSystemGetDictionary(system);
    ficlDictionary *environment = ficlSystemGetEnvironment(system);
#if FICL_WANT_FLOAT
    ficlCell data;
#endif

    FICL_SYSTEM_ASSERT(system, dictionary);
    FICL_SYSTEM_ASSERT(system, environment);

#if FICL_WANT_LOCALS
    ficlDictionarySetPrimitive(dictionary, "(flocal)",
        ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY);
    ficlDictionarySetPrimitive(dictionary, "(f2local)",
        ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY);
#endif /* FICL_WANT_LOCALS */

#if FICL_WANT_FLOAT
    ficlDictionarySetPrimitive(dictionary, "fconstant",
        ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "fvalue",
        ficlPrimitiveFConstant, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "f2constant",
        ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "f2value",
        ficlPrimitiveF2Constant, FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "fdepth", ficlPrimitiveFDepth,
        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "fliteral",
        ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE);
    ficlDictionarySetPrimitive(dictionary, "f.", ficlPrimitiveFDot,
        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "f.s", ficlVmDisplayFloatStack,
        FICL_WORD_DEFAULT);
    ficlDictionarySetPrimitive(dictionary, "fe.", ficlPrimitiveEDot,
        FICL_WORD_DEFAULT);

    /*
     * Missing words:
     *
     * d>f
     * f>d
     * falign
     * faligned
     * float+
     * floats
     * floor
     * fmax
     * fmin
     */

#if defined(_LP64)
    data.f = MAXDOUBLE;
#else
    data.f = MAXFLOAT;
#endif
    ficlDictionarySetConstant(environment, "max-float", data.i);
    /* not all required words are present */
    ficlDictionarySetConstant(environment, "floating", FICL_FALSE);
    ficlDictionarySetConstant(environment, "floating-ext", FICL_FALSE);
    ficlDictionarySetConstant(environment, "floating-stack",
        system->stackSize);
#else
    ficlDictionarySetConstant(environment, "floating", FICL_FALSE);
#endif
}