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