From afc2ba1deb75b323afde536f2dd18bcafdaa308d Mon Sep 17 00:00:00 2001 From: Toomas Soome Date: Sun, 30 Aug 2015 15:37:04 +0300 Subject: 6185 want ficl scripting engine in illumos (loader project) Reviewed by: Richard Lowe Reviewed by: Andrew Stormont Approved by: Robert Mustacchi --- usr/src/common/ficl/float.c | 474 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 474 insertions(+) create mode 100644 usr/src/common/ficl/float.c (limited to 'usr/src/common/ficl/float.c') diff --git a/usr/src/common/ficl/float.c b/usr/src/common/ficl/float.c new file mode 100644 index 0000000000..3442259f59 --- /dev/null +++ b/usr/src/common/ficl/float.c @@ -0,0 +1,474 @@ +/* + * 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 +#include + + +/* + * 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 +} -- cgit v1.2.3