usr/src/common/ficl/float.c

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