1*afc2ba1dSToomas Soome /* 2*afc2ba1dSToomas Soome * f l o a t . c 3*afc2ba1dSToomas Soome * Forth Inspired Command Language 4*afc2ba1dSToomas Soome * ANS Forth FLOAT word-set written in C 5*afc2ba1dSToomas Soome * Author: Guy Carver & John Sadler (john_sadler@alum.mit.edu) 6*afc2ba1dSToomas Soome * Created: Apr 2001 7*afc2ba1dSToomas Soome * $Id: float.c,v 1.10 2010/09/13 18:43:04 asau Exp $ 8*afc2ba1dSToomas Soome */ 9*afc2ba1dSToomas Soome /* 10*afc2ba1dSToomas Soome * Copyright (c) 1997-2001 John Sadler (john_sadler@alum.mit.edu) 11*afc2ba1dSToomas Soome * All rights reserved. 12*afc2ba1dSToomas Soome * 13*afc2ba1dSToomas Soome * Get the latest Ficl release at http://ficl.sourceforge.net 14*afc2ba1dSToomas Soome * 15*afc2ba1dSToomas Soome * I am interested in hearing from anyone who uses Ficl. If you have 16*afc2ba1dSToomas Soome * a problem, a success story, a defect, an enhancement request, or 17*afc2ba1dSToomas Soome * if you would like to contribute to the Ficl release, please 18*afc2ba1dSToomas Soome * contact me by email at the address above. 19*afc2ba1dSToomas Soome * 20*afc2ba1dSToomas Soome * L I C E N S E and D I S C L A I M E R 21*afc2ba1dSToomas Soome * 22*afc2ba1dSToomas Soome * Redistribution and use in source and binary forms, with or without 23*afc2ba1dSToomas Soome * modification, are permitted provided that the following conditions 24*afc2ba1dSToomas Soome * are met: 25*afc2ba1dSToomas Soome * 1. Redistributions of source code must retain the above copyright 26*afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer. 27*afc2ba1dSToomas Soome * 2. Redistributions in binary form must reproduce the above copyright 28*afc2ba1dSToomas Soome * notice, this list of conditions and the following disclaimer in the 29*afc2ba1dSToomas Soome * documentation and/or other materials provided with the distribution. 30*afc2ba1dSToomas Soome * 31*afc2ba1dSToomas Soome * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 32*afc2ba1dSToomas Soome * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 33*afc2ba1dSToomas Soome * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 34*afc2ba1dSToomas Soome * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 35*afc2ba1dSToomas Soome * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 36*afc2ba1dSToomas Soome * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 37*afc2ba1dSToomas Soome * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 38*afc2ba1dSToomas Soome * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 39*afc2ba1dSToomas Soome * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 40*afc2ba1dSToomas Soome * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 41*afc2ba1dSToomas Soome * SUCH DAMAGE. 42*afc2ba1dSToomas Soome */ 43*afc2ba1dSToomas Soome 44*afc2ba1dSToomas Soome #include "ficl.h" 45*afc2ba1dSToomas Soome 46*afc2ba1dSToomas Soome #if FICL_WANT_FLOAT 47*afc2ba1dSToomas Soome #include <math.h> 48*afc2ba1dSToomas Soome #include <values.h> 49*afc2ba1dSToomas Soome 50*afc2ba1dSToomas Soome 51*afc2ba1dSToomas Soome /* 52*afc2ba1dSToomas Soome * Create a floating point constant. 53*afc2ba1dSToomas Soome * fconstant ( r -"name"- ) 54*afc2ba1dSToomas Soome */ 55*afc2ba1dSToomas Soome static void 56*afc2ba1dSToomas Soome ficlPrimitiveFConstant(ficlVm *vm) 57*afc2ba1dSToomas Soome { 58*afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 59*afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm); 60*afc2ba1dSToomas Soome 61*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0); 62*afc2ba1dSToomas Soome 63*afc2ba1dSToomas Soome ficlDictionaryAppendWord(dictionary, name, 64*afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionFConstantParen, FICL_WORD_DEFAULT); 65*afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack)); 66*afc2ba1dSToomas Soome } 67*afc2ba1dSToomas Soome 68*afc2ba1dSToomas Soome 69*afc2ba1dSToomas Soome ficlWord * 70*afc2ba1dSToomas Soome ficlDictionaryAppendFConstant(ficlDictionary *dictionary, char *name, 71*afc2ba1dSToomas Soome ficlFloat value) 72*afc2ba1dSToomas Soome { 73*afc2ba1dSToomas Soome ficlString s; 74*afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name); 75*afc2ba1dSToomas Soome return (ficlDictionaryAppendConstantInstruction(dictionary, s, 76*afc2ba1dSToomas Soome ficlInstructionFConstantParen, *(ficlInteger *)(&value))); 77*afc2ba1dSToomas Soome } 78*afc2ba1dSToomas Soome 79*afc2ba1dSToomas Soome 80*afc2ba1dSToomas Soome ficlWord * 81*afc2ba1dSToomas Soome ficlDictionarySetFConstant(ficlDictionary *dictionary, char *name, 82*afc2ba1dSToomas Soome ficlFloat value) 83*afc2ba1dSToomas Soome { 84*afc2ba1dSToomas Soome ficlString s; 85*afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name); 86*afc2ba1dSToomas Soome return (ficlDictionarySetConstantInstruction(dictionary, s, 87*afc2ba1dSToomas Soome ficlInstructionFConstantParen, *(ficlInteger *)(&value))); 88*afc2ba1dSToomas Soome } 89*afc2ba1dSToomas Soome 90*afc2ba1dSToomas Soome 91*afc2ba1dSToomas Soome 92*afc2ba1dSToomas Soome 93*afc2ba1dSToomas Soome static void 94*afc2ba1dSToomas Soome ficlPrimitiveF2Constant(ficlVm *vm) 95*afc2ba1dSToomas Soome { 96*afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 97*afc2ba1dSToomas Soome ficlString name = ficlVmGetWord(vm); 98*afc2ba1dSToomas Soome 99*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 2, 0); 100*afc2ba1dSToomas Soome 101*afc2ba1dSToomas Soome ficlDictionaryAppendWord(dictionary, name, 102*afc2ba1dSToomas Soome (ficlPrimitive)ficlInstructionF2ConstantParen, FICL_WORD_DEFAULT); 103*afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack)); 104*afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, ficlStackPop(vm->floatStack)); 105*afc2ba1dSToomas Soome } 106*afc2ba1dSToomas Soome 107*afc2ba1dSToomas Soome ficlWord * 108*afc2ba1dSToomas Soome ficlDictionaryAppendF2Constant(ficlDictionary *dictionary, char *name, 109*afc2ba1dSToomas Soome ficlFloat value) 110*afc2ba1dSToomas Soome { 111*afc2ba1dSToomas Soome ficlString s; 112*afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name); 113*afc2ba1dSToomas Soome return (ficlDictionaryAppend2ConstantInstruction(dictionary, s, 114*afc2ba1dSToomas Soome ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value))); 115*afc2ba1dSToomas Soome } 116*afc2ba1dSToomas Soome 117*afc2ba1dSToomas Soome ficlWord * 118*afc2ba1dSToomas Soome ficlDictionarySetF2Constant(ficlDictionary *dictionary, char *name, 119*afc2ba1dSToomas Soome ficlFloat value) 120*afc2ba1dSToomas Soome { 121*afc2ba1dSToomas Soome ficlString s; 122*afc2ba1dSToomas Soome FICL_STRING_SET_FROM_CSTRING(s, name); 123*afc2ba1dSToomas Soome return (ficlDictionarySet2ConstantInstruction(dictionary, s, 124*afc2ba1dSToomas Soome ficlInstructionF2ConstantParen, *(ficl2Integer *)(&value))); 125*afc2ba1dSToomas Soome } 126*afc2ba1dSToomas Soome 127*afc2ba1dSToomas Soome /* 128*afc2ba1dSToomas Soome * Display a float in decimal format. 129*afc2ba1dSToomas Soome * f. ( r -- ) 130*afc2ba1dSToomas Soome */ 131*afc2ba1dSToomas Soome static void 132*afc2ba1dSToomas Soome ficlPrimitiveFDot(ficlVm *vm) 133*afc2ba1dSToomas Soome { 134*afc2ba1dSToomas Soome ficlFloat f; 135*afc2ba1dSToomas Soome 136*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0); 137*afc2ba1dSToomas Soome 138*afc2ba1dSToomas Soome f = ficlStackPopFloat(vm->floatStack); 139*afc2ba1dSToomas Soome sprintf(vm->pad, "%#f ", f); 140*afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 141*afc2ba1dSToomas Soome } 142*afc2ba1dSToomas Soome 143*afc2ba1dSToomas Soome /* 144*afc2ba1dSToomas Soome * Display a float in engineering format. 145*afc2ba1dSToomas Soome * fe. ( r -- ) 146*afc2ba1dSToomas Soome */ 147*afc2ba1dSToomas Soome static void 148*afc2ba1dSToomas Soome ficlPrimitiveEDot(ficlVm *vm) 149*afc2ba1dSToomas Soome { 150*afc2ba1dSToomas Soome ficlFloat f; 151*afc2ba1dSToomas Soome 152*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0); 153*afc2ba1dSToomas Soome 154*afc2ba1dSToomas Soome f = ficlStackPopFloat(vm->floatStack); 155*afc2ba1dSToomas Soome sprintf(vm->pad, "%#e ", f); 156*afc2ba1dSToomas Soome ficlVmTextOut(vm, vm->pad); 157*afc2ba1dSToomas Soome } 158*afc2ba1dSToomas Soome 159*afc2ba1dSToomas Soome /* 160*afc2ba1dSToomas Soome * d i s p l a y FS t a c k 161*afc2ba1dSToomas Soome * Display the parameter stack (code for "f.s") 162*afc2ba1dSToomas Soome * f.s ( -- ) 163*afc2ba1dSToomas Soome */ 164*afc2ba1dSToomas Soome struct stackContext 165*afc2ba1dSToomas Soome { 166*afc2ba1dSToomas Soome ficlVm *vm; 167*afc2ba1dSToomas Soome int count; 168*afc2ba1dSToomas Soome }; 169*afc2ba1dSToomas Soome 170*afc2ba1dSToomas Soome static ficlInteger 171*afc2ba1dSToomas Soome ficlFloatStackDisplayCallback(void *c, ficlCell *cell) 172*afc2ba1dSToomas Soome { 173*afc2ba1dSToomas Soome struct stackContext *context = (struct stackContext *)c; 174*afc2ba1dSToomas Soome char buffer[80]; 175*afc2ba1dSToomas Soome #ifdef _LP64 176*afc2ba1dSToomas Soome snprintf(buffer, sizeof (buffer), "[0x%016lx %3d] %20e (0x%016lx)\n", 177*afc2ba1dSToomas Soome (unsigned long) cell, context->count++, cell->f, cell->u); 178*afc2ba1dSToomas Soome #else 179*afc2ba1dSToomas Soome snprintf(buffer, sizeof (buffer), "[0x%08x %3d] %12e (0x%08x)\n", 180*afc2ba1dSToomas Soome (unsigned)cell, context->count++, cell->f, cell->u); 181*afc2ba1dSToomas Soome #endif 182*afc2ba1dSToomas Soome ficlVmTextOut(context->vm, buffer); 183*afc2ba1dSToomas Soome return (FICL_TRUE); 184*afc2ba1dSToomas Soome } 185*afc2ba1dSToomas Soome 186*afc2ba1dSToomas Soome void 187*afc2ba1dSToomas Soome ficlVmDisplayFloatStack(ficlVm *vm) 188*afc2ba1dSToomas Soome { 189*afc2ba1dSToomas Soome struct stackContext context; 190*afc2ba1dSToomas Soome context.vm = vm; 191*afc2ba1dSToomas Soome context.count = 0; 192*afc2ba1dSToomas Soome ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback, 193*afc2ba1dSToomas Soome &context); 194*afc2ba1dSToomas Soome } 195*afc2ba1dSToomas Soome 196*afc2ba1dSToomas Soome /* 197*afc2ba1dSToomas Soome * Do float stack depth. 198*afc2ba1dSToomas Soome * fdepth ( -- n ) 199*afc2ba1dSToomas Soome */ 200*afc2ba1dSToomas Soome static void 201*afc2ba1dSToomas Soome ficlPrimitiveFDepth(ficlVm *vm) 202*afc2ba1dSToomas Soome { 203*afc2ba1dSToomas Soome int i; 204*afc2ba1dSToomas Soome 205*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->dataStack, 0, 1); 206*afc2ba1dSToomas Soome 207*afc2ba1dSToomas Soome i = ficlStackDepth(vm->floatStack); 208*afc2ba1dSToomas Soome ficlStackPushInteger(vm->dataStack, i); 209*afc2ba1dSToomas Soome } 210*afc2ba1dSToomas Soome 211*afc2ba1dSToomas Soome /* 212*afc2ba1dSToomas Soome * Compile a floating point literal. 213*afc2ba1dSToomas Soome */ 214*afc2ba1dSToomas Soome static void 215*afc2ba1dSToomas Soome ficlPrimitiveFLiteralImmediate(ficlVm *vm) 216*afc2ba1dSToomas Soome { 217*afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlVmGetDictionary(vm); 218*afc2ba1dSToomas Soome ficlCell cell; 219*afc2ba1dSToomas Soome 220*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 1, 0); 221*afc2ba1dSToomas Soome 222*afc2ba1dSToomas Soome cell = ficlStackPop(vm->floatStack); 223*afc2ba1dSToomas Soome if (cell.f == 1.0f) { 224*afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1); 225*afc2ba1dSToomas Soome } else if (cell.f == 0.0f) { 226*afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0); 227*afc2ba1dSToomas Soome } else if (cell.f == -1.0f) { 228*afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1); 229*afc2ba1dSToomas Soome } else { 230*afc2ba1dSToomas Soome ficlDictionaryAppendUnsigned(dictionary, 231*afc2ba1dSToomas Soome ficlInstructionFLiteralParen); 232*afc2ba1dSToomas Soome ficlDictionaryAppendCell(dictionary, cell); 233*afc2ba1dSToomas Soome } 234*afc2ba1dSToomas Soome } 235*afc2ba1dSToomas Soome 236*afc2ba1dSToomas Soome /* 237*afc2ba1dSToomas Soome * F l o a t P a r s e S t a t e 238*afc2ba1dSToomas Soome * Enum to determine the current segement of a floating point number 239*afc2ba1dSToomas Soome * being parsed. 240*afc2ba1dSToomas Soome */ 241*afc2ba1dSToomas Soome #define NUMISNEG 1 242*afc2ba1dSToomas Soome #define EXPISNEG 2 243*afc2ba1dSToomas Soome 244*afc2ba1dSToomas Soome typedef enum _floatParseState 245*afc2ba1dSToomas Soome { 246*afc2ba1dSToomas Soome FPS_START, 247*afc2ba1dSToomas Soome FPS_ININT, 248*afc2ba1dSToomas Soome FPS_INMANT, 249*afc2ba1dSToomas Soome FPS_STARTEXP, 250*afc2ba1dSToomas Soome FPS_INEXP 251*afc2ba1dSToomas Soome } FloatParseState; 252*afc2ba1dSToomas Soome 253*afc2ba1dSToomas Soome /* 254*afc2ba1dSToomas Soome * f i c l P a r s e F l o a t N u m b e r 255*afc2ba1dSToomas Soome * vm -- Virtual Machine pointer. 256*afc2ba1dSToomas Soome * s -- String to parse. 257*afc2ba1dSToomas Soome * Returns 1 if successful, 0 if not. 258*afc2ba1dSToomas Soome */ 259*afc2ba1dSToomas Soome int 260*afc2ba1dSToomas Soome ficlVmParseFloatNumber(ficlVm *vm, ficlString s) 261*afc2ba1dSToomas Soome { 262*afc2ba1dSToomas Soome unsigned char c; 263*afc2ba1dSToomas Soome unsigned char digit; 264*afc2ba1dSToomas Soome char *trace; 265*afc2ba1dSToomas Soome ficlUnsigned length; 266*afc2ba1dSToomas Soome ficlFloat power; 267*afc2ba1dSToomas Soome ficlFloat accum = 0.0f; 268*afc2ba1dSToomas Soome ficlFloat mant = 0.1f; 269*afc2ba1dSToomas Soome ficlInteger exponent = 0; 270*afc2ba1dSToomas Soome char flag = 0; 271*afc2ba1dSToomas Soome FloatParseState estate = FPS_START; 272*afc2ba1dSToomas Soome 273*afc2ba1dSToomas Soome FICL_STACK_CHECK(vm->floatStack, 0, 1); 274*afc2ba1dSToomas Soome 275*afc2ba1dSToomas Soome /* 276*afc2ba1dSToomas Soome * floating point numbers only allowed in base 10 277*afc2ba1dSToomas Soome */ 278*afc2ba1dSToomas Soome if (vm->base != 10) 279*afc2ba1dSToomas Soome return (0); 280*afc2ba1dSToomas Soome 281*afc2ba1dSToomas Soome trace = FICL_STRING_GET_POINTER(s); 282*afc2ba1dSToomas Soome length = FICL_STRING_GET_LENGTH(s); 283*afc2ba1dSToomas Soome 284*afc2ba1dSToomas Soome /* Loop through the string's characters. */ 285*afc2ba1dSToomas Soome while ((length--) && ((c = *trace++) != 0)) { 286*afc2ba1dSToomas Soome switch (estate) { 287*afc2ba1dSToomas Soome /* At start of the number so look for a sign. */ 288*afc2ba1dSToomas Soome case FPS_START: 289*afc2ba1dSToomas Soome estate = FPS_ININT; 290*afc2ba1dSToomas Soome if (c == '-') { 291*afc2ba1dSToomas Soome flag |= NUMISNEG; 292*afc2ba1dSToomas Soome break; 293*afc2ba1dSToomas Soome } 294*afc2ba1dSToomas Soome if (c == '+') { 295*afc2ba1dSToomas Soome break; 296*afc2ba1dSToomas Soome } 297*afc2ba1dSToomas Soome /* Note! Drop through to FPS_ININT */ 298*afc2ba1dSToomas Soome /* 299*afc2ba1dSToomas Soome * Converting integer part of number. 300*afc2ba1dSToomas Soome * Only allow digits, decimal and 'E'. 301*afc2ba1dSToomas Soome */ 302*afc2ba1dSToomas Soome case FPS_ININT: 303*afc2ba1dSToomas Soome if (c == '.') { 304*afc2ba1dSToomas Soome estate = FPS_INMANT; 305*afc2ba1dSToomas Soome } else if ((c == 'e') || (c == 'E')) { 306*afc2ba1dSToomas Soome estate = FPS_STARTEXP; 307*afc2ba1dSToomas Soome } else { 308*afc2ba1dSToomas Soome digit = (unsigned char)(c - '0'); 309*afc2ba1dSToomas Soome if (digit > 9) 310*afc2ba1dSToomas Soome return (0); 311*afc2ba1dSToomas Soome 312*afc2ba1dSToomas Soome accum = accum * 10 + digit; 313*afc2ba1dSToomas Soome } 314*afc2ba1dSToomas Soome break; 315*afc2ba1dSToomas Soome /* 316*afc2ba1dSToomas Soome * Processing the fraction part of number. 317*afc2ba1dSToomas Soome * Only allow digits and 'E' 318*afc2ba1dSToomas Soome */ 319*afc2ba1dSToomas Soome case FPS_INMANT: 320*afc2ba1dSToomas Soome if ((c == 'e') || (c == 'E')) { 321*afc2ba1dSToomas Soome estate = FPS_STARTEXP; 322*afc2ba1dSToomas Soome } else { 323*afc2ba1dSToomas Soome digit = (unsigned char)(c - '0'); 324*afc2ba1dSToomas Soome if (digit > 9) 325*afc2ba1dSToomas Soome return (0); 326*afc2ba1dSToomas Soome 327*afc2ba1dSToomas Soome accum += digit * mant; 328*afc2ba1dSToomas Soome mant *= 0.1f; 329*afc2ba1dSToomas Soome } 330*afc2ba1dSToomas Soome break; 331*afc2ba1dSToomas Soome /* Start processing the exponent part of number. */ 332*afc2ba1dSToomas Soome /* Look for sign. */ 333*afc2ba1dSToomas Soome case FPS_STARTEXP: 334*afc2ba1dSToomas Soome estate = FPS_INEXP; 335*afc2ba1dSToomas Soome 336*afc2ba1dSToomas Soome if (c == '-') { 337*afc2ba1dSToomas Soome flag |= EXPISNEG; 338*afc2ba1dSToomas Soome break; 339*afc2ba1dSToomas Soome } else if (c == '+') { 340*afc2ba1dSToomas Soome break; 341*afc2ba1dSToomas Soome } 342*afc2ba1dSToomas Soome /* Note! Drop through to FPS_INEXP */ 343*afc2ba1dSToomas Soome /* 344*afc2ba1dSToomas Soome * Processing the exponent part of number. 345*afc2ba1dSToomas Soome * Only allow digits. 346*afc2ba1dSToomas Soome */ 347*afc2ba1dSToomas Soome case FPS_INEXP: 348*afc2ba1dSToomas Soome digit = (unsigned char)(c - '0'); 349*afc2ba1dSToomas Soome if (digit > 9) 350*afc2ba1dSToomas Soome return (0); 351*afc2ba1dSToomas Soome 352*afc2ba1dSToomas Soome exponent = exponent * 10 + digit; 353*afc2ba1dSToomas Soome 354*afc2ba1dSToomas Soome break; 355*afc2ba1dSToomas Soome } 356*afc2ba1dSToomas Soome } 357*afc2ba1dSToomas Soome 358*afc2ba1dSToomas Soome /* If parser never made it to the exponent this is not a float. */ 359*afc2ba1dSToomas Soome if (estate < FPS_STARTEXP) 360*afc2ba1dSToomas Soome return (0); 361*afc2ba1dSToomas Soome 362*afc2ba1dSToomas Soome /* Set the sign of the number. */ 363*afc2ba1dSToomas Soome if (flag & NUMISNEG) 364*afc2ba1dSToomas Soome accum = -accum; 365*afc2ba1dSToomas Soome 366*afc2ba1dSToomas Soome /* If exponent is not 0 then adjust number by it. */ 367*afc2ba1dSToomas Soome if (exponent != 0) { 368*afc2ba1dSToomas Soome /* Determine if exponent is negative. */ 369*afc2ba1dSToomas Soome if (flag & EXPISNEG) { 370*afc2ba1dSToomas Soome exponent = -exponent; 371*afc2ba1dSToomas Soome } 372*afc2ba1dSToomas Soome /* power = 10^x */ 373*afc2ba1dSToomas Soome #if defined(_LP64) 374*afc2ba1dSToomas Soome power = (ficlFloat)pow(10.0, exponent); 375*afc2ba1dSToomas Soome #else 376*afc2ba1dSToomas Soome power = (ficlFloat)powf(10.0, exponent); 377*afc2ba1dSToomas Soome #endif 378*afc2ba1dSToomas Soome accum *= power; 379*afc2ba1dSToomas Soome } 380*afc2ba1dSToomas Soome 381*afc2ba1dSToomas Soome ficlStackPushFloat(vm->floatStack, accum); 382*afc2ba1dSToomas Soome if (vm->state == FICL_VM_STATE_COMPILE) 383*afc2ba1dSToomas Soome ficlPrimitiveFLiteralImmediate(vm); 384*afc2ba1dSToomas Soome 385*afc2ba1dSToomas Soome return (1); 386*afc2ba1dSToomas Soome } 387*afc2ba1dSToomas Soome #endif /* FICL_WANT_FLOAT */ 388*afc2ba1dSToomas Soome 389*afc2ba1dSToomas Soome #if FICL_WANT_LOCALS 390*afc2ba1dSToomas Soome static void 391*afc2ba1dSToomas Soome ficlPrimitiveFLocalParen(ficlVm *vm) 392*afc2ba1dSToomas Soome { 393*afc2ba1dSToomas Soome ficlLocalParen(vm, 0, 1); 394*afc2ba1dSToomas Soome } 395*afc2ba1dSToomas Soome 396*afc2ba1dSToomas Soome static void 397*afc2ba1dSToomas Soome ficlPrimitiveF2LocalParen(ficlVm *vm) 398*afc2ba1dSToomas Soome { 399*afc2ba1dSToomas Soome ficlLocalParen(vm, 1, 1); 400*afc2ba1dSToomas Soome } 401*afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */ 402*afc2ba1dSToomas Soome 403*afc2ba1dSToomas Soome /* 404*afc2ba1dSToomas Soome * Add float words to a system's dictionary. 405*afc2ba1dSToomas Soome * system -- Pointer to the Ficl sytem to add float words to. 406*afc2ba1dSToomas Soome */ 407*afc2ba1dSToomas Soome void 408*afc2ba1dSToomas Soome ficlSystemCompileFloat(ficlSystem *system) 409*afc2ba1dSToomas Soome { 410*afc2ba1dSToomas Soome ficlDictionary *dictionary = ficlSystemGetDictionary(system); 411*afc2ba1dSToomas Soome ficlDictionary *environment = ficlSystemGetEnvironment(system); 412*afc2ba1dSToomas Soome #if FICL_WANT_FLOAT 413*afc2ba1dSToomas Soome ficlCell data; 414*afc2ba1dSToomas Soome #endif 415*afc2ba1dSToomas Soome 416*afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, dictionary); 417*afc2ba1dSToomas Soome FICL_SYSTEM_ASSERT(system, environment); 418*afc2ba1dSToomas Soome 419*afc2ba1dSToomas Soome #if FICL_WANT_LOCALS 420*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "(flocal)", 421*afc2ba1dSToomas Soome ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY); 422*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "(f2local)", 423*afc2ba1dSToomas Soome ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY); 424*afc2ba1dSToomas Soome #endif /* FICL_WANT_LOCALS */ 425*afc2ba1dSToomas Soome 426*afc2ba1dSToomas Soome #if FICL_WANT_FLOAT 427*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "fconstant", 428*afc2ba1dSToomas Soome ficlPrimitiveFConstant, FICL_WORD_DEFAULT); 429*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "fvalue", 430*afc2ba1dSToomas Soome ficlPrimitiveFConstant, FICL_WORD_DEFAULT); 431*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "f2constant", 432*afc2ba1dSToomas Soome ficlPrimitiveF2Constant, FICL_WORD_DEFAULT); 433*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "f2value", 434*afc2ba1dSToomas Soome ficlPrimitiveF2Constant, FICL_WORD_DEFAULT); 435*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "fdepth", ficlPrimitiveFDepth, 436*afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 437*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "fliteral", 438*afc2ba1dSToomas Soome ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE); 439*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "f.", ficlPrimitiveFDot, 440*afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 441*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "f.s", ficlVmDisplayFloatStack, 442*afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 443*afc2ba1dSToomas Soome ficlDictionarySetPrimitive(dictionary, "fe.", ficlPrimitiveEDot, 444*afc2ba1dSToomas Soome FICL_WORD_DEFAULT); 445*afc2ba1dSToomas Soome 446*afc2ba1dSToomas Soome /* 447*afc2ba1dSToomas Soome * Missing words: 448*afc2ba1dSToomas Soome * 449*afc2ba1dSToomas Soome * d>f 450*afc2ba1dSToomas Soome * f>d 451*afc2ba1dSToomas Soome * falign 452*afc2ba1dSToomas Soome * faligned 453*afc2ba1dSToomas Soome * float+ 454*afc2ba1dSToomas Soome * floats 455*afc2ba1dSToomas Soome * floor 456*afc2ba1dSToomas Soome * fmax 457*afc2ba1dSToomas Soome * fmin 458*afc2ba1dSToomas Soome */ 459*afc2ba1dSToomas Soome 460*afc2ba1dSToomas Soome #if defined(_LP64) 461*afc2ba1dSToomas Soome data.f = MAXDOUBLE; 462*afc2ba1dSToomas Soome #else 463*afc2ba1dSToomas Soome data.f = MAXFLOAT; 464*afc2ba1dSToomas Soome #endif 465*afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "max-float", data.i); 466*afc2ba1dSToomas Soome /* not all required words are present */ 467*afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "floating", FICL_FALSE); 468*afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "floating-ext", FICL_FALSE); 469*afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "floating-stack", 470*afc2ba1dSToomas Soome system->stackSize); 471*afc2ba1dSToomas Soome #else 472*afc2ba1dSToomas Soome ficlDictionarySetConstant(environment, "floating", FICL_FALSE); 473*afc2ba1dSToomas Soome #endif 474*afc2ba1dSToomas Soome } 475