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 (void) 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 (void) 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 (void) 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 (void) 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 (void) snprintf(buffer, sizeof (buffer), 177 "[0x%016lx %3d] %20e (0x%016lx)\n", 178 (unsigned long) cell, context->count++, cell->f, cell->u); 179 #else 180 (void) snprintf(buffer, sizeof (buffer), "[0x%08x %3d] %12e (0x%08x)\n", 181 (unsigned)cell, context->count++, cell->f, cell->u); 182 #endif 183 ficlVmTextOut(context->vm, buffer); 184 return (FICL_TRUE); 185 } 186 187 void 188 ficlVmDisplayFloatStack(ficlVm *vm) 189 { 190 struct stackContext context; 191 context.vm = vm; 192 context.count = 0; 193 ficlStackDisplay(vm->floatStack, ficlFloatStackDisplayCallback, 194 &context); 195 } 196 197 /* 198 * Do float stack depth. 199 * fdepth ( -- n ) 200 */ 201 static void 202 ficlPrimitiveFDepth(ficlVm *vm) 203 { 204 int i; 205 206 FICL_STACK_CHECK(vm->dataStack, 0, 1); 207 208 i = ficlStackDepth(vm->floatStack); 209 ficlStackPushInteger(vm->dataStack, i); 210 } 211 212 /* 213 * Compile a floating point literal. 214 */ 215 static void 216 ficlPrimitiveFLiteralImmediate(ficlVm *vm) 217 { 218 ficlDictionary *dictionary = ficlVmGetDictionary(vm); 219 ficlCell cell; 220 221 FICL_STACK_CHECK(vm->floatStack, 1, 0); 222 223 cell = ficlStackPop(vm->floatStack); 224 if (cell.f == 1.0f) { 225 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF1); 226 } else if (cell.f == 0.0f) { 227 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionF0); 228 } else if (cell.f == -1.0f) { 229 ficlDictionaryAppendUnsigned(dictionary, ficlInstructionFNeg1); 230 } else { 231 ficlDictionaryAppendUnsigned(dictionary, 232 ficlInstructionFLiteralParen); 233 ficlDictionaryAppendCell(dictionary, cell); 234 } 235 } 236 237 /* 238 * F l o a t P a r s e S t a t e 239 * Enum to determine the current segement of a floating point number 240 * being parsed. 241 */ 242 #define NUMISNEG 1 243 #define EXPISNEG 2 244 245 typedef enum _floatParseState 246 { 247 FPS_START, 248 FPS_ININT, 249 FPS_INMANT, 250 FPS_STARTEXP, 251 FPS_INEXP 252 } FloatParseState; 253 254 /* 255 * f i c l P a r s e F l o a t N u m b e r 256 * vm -- Virtual Machine pointer. 257 * s -- String to parse. 258 * Returns 1 if successful, 0 if not. 259 */ 260 int 261 ficlVmParseFloatNumber(ficlVm *vm, ficlString s) 262 { 263 unsigned char c; 264 unsigned char digit; 265 char *trace; 266 ficlUnsigned length; 267 ficlFloat power; 268 ficlFloat accum = 0.0f; 269 ficlFloat mant = 0.1f; 270 ficlInteger exponent = 0; 271 char flag = 0; 272 FloatParseState estate = FPS_START; 273 274 FICL_STACK_CHECK(vm->floatStack, 0, 1); 275 276 /* 277 * floating point numbers only allowed in base 10 278 */ 279 if (vm->base != 10) 280 return (0); 281 282 trace = FICL_STRING_GET_POINTER(s); 283 length = FICL_STRING_GET_LENGTH(s); 284 285 /* Loop through the string's characters. */ 286 while ((length--) && ((c = *trace++) != 0)) { 287 switch (estate) { 288 /* At start of the number so look for a sign. */ 289 case FPS_START: 290 estate = FPS_ININT; 291 if (c == '-') { 292 flag |= NUMISNEG; 293 break; 294 } 295 if (c == '+') { 296 break; 297 } 298 /* FALLTHROUGH */ 299 /* 300 * Converting integer part of number. 301 * Only allow digits, decimal and 'E'. 302 */ 303 case FPS_ININT: 304 if (c == '.') { 305 estate = FPS_INMANT; 306 } else if ((c == 'e') || (c == 'E')) { 307 estate = FPS_STARTEXP; 308 } else { 309 digit = (unsigned char)(c - '0'); 310 if (digit > 9) 311 return (0); 312 313 accum = accum * 10 + digit; 314 } 315 break; 316 /* 317 * Processing the fraction part of number. 318 * Only allow digits and 'E' 319 */ 320 case FPS_INMANT: 321 if ((c == 'e') || (c == 'E')) { 322 estate = FPS_STARTEXP; 323 } else { 324 digit = (unsigned char)(c - '0'); 325 if (digit > 9) 326 return (0); 327 328 accum += digit * mant; 329 mant *= 0.1f; 330 } 331 break; 332 /* Start processing the exponent part of number. */ 333 /* Look for sign. */ 334 case FPS_STARTEXP: 335 estate = FPS_INEXP; 336 337 if (c == '-') { 338 flag |= EXPISNEG; 339 break; 340 } else if (c == '+') { 341 break; 342 } 343 /* FALLTHROUGH */ 344 /* 345 * Processing the exponent part of number. 346 * Only allow digits. 347 */ 348 case FPS_INEXP: 349 digit = (unsigned char)(c - '0'); 350 if (digit > 9) 351 return (0); 352 353 exponent = exponent * 10 + digit; 354 355 break; 356 } 357 } 358 359 /* If parser never made it to the exponent this is not a float. */ 360 if (estate < FPS_STARTEXP) 361 return (0); 362 363 /* Set the sign of the number. */ 364 if (flag & NUMISNEG) 365 accum = -accum; 366 367 /* If exponent is not 0 then adjust number by it. */ 368 if (exponent != 0) { 369 /* Determine if exponent is negative. */ 370 if (flag & EXPISNEG) { 371 exponent = -exponent; 372 } 373 /* power = 10^x */ 374 #if defined(_LP64) 375 power = (ficlFloat)pow(10.0, exponent); 376 #else 377 power = (ficlFloat)powf(10.0, exponent); 378 #endif 379 accum *= power; 380 } 381 382 ficlStackPushFloat(vm->floatStack, accum); 383 if (vm->state == FICL_VM_STATE_COMPILE) 384 ficlPrimitiveFLiteralImmediate(vm); 385 386 return (1); 387 } 388 #endif /* FICL_WANT_FLOAT */ 389 390 #if FICL_WANT_LOCALS 391 static void 392 ficlPrimitiveFLocalParen(ficlVm *vm) 393 { 394 ficlLocalParen(vm, 0, 1); 395 } 396 397 static void 398 ficlPrimitiveF2LocalParen(ficlVm *vm) 399 { 400 ficlLocalParen(vm, 1, 1); 401 } 402 #endif /* FICL_WANT_LOCALS */ 403 404 /* 405 * Add float words to a system's dictionary. 406 * system -- Pointer to the Ficl system to add float words to. 407 */ 408 void 409 ficlSystemCompileFloat(ficlSystem *system) 410 { 411 ficlDictionary *dictionary = ficlSystemGetDictionary(system); 412 ficlDictionary *environment = ficlSystemGetEnvironment(system); 413 #if FICL_WANT_FLOAT 414 ficlCell data; 415 #endif 416 417 FICL_SYSTEM_ASSERT(system, dictionary); 418 FICL_SYSTEM_ASSERT(system, environment); 419 420 #if FICL_WANT_LOCALS 421 (void) ficlDictionarySetPrimitive(dictionary, "(flocal)", 422 ficlPrimitiveFLocalParen, FICL_WORD_COMPILE_ONLY); 423 (void) ficlDictionarySetPrimitive(dictionary, "(f2local)", 424 ficlPrimitiveF2LocalParen, FICL_WORD_COMPILE_ONLY); 425 #endif /* FICL_WANT_LOCALS */ 426 427 #if FICL_WANT_FLOAT 428 (void) ficlDictionarySetPrimitive(dictionary, "fconstant", 429 ficlPrimitiveFConstant, FICL_WORD_DEFAULT); 430 (void) ficlDictionarySetPrimitive(dictionary, "fvalue", 431 ficlPrimitiveFConstant, FICL_WORD_DEFAULT); 432 (void) ficlDictionarySetPrimitive(dictionary, "f2constant", 433 ficlPrimitiveF2Constant, FICL_WORD_DEFAULT); 434 (void) ficlDictionarySetPrimitive(dictionary, "f2value", 435 ficlPrimitiveF2Constant, FICL_WORD_DEFAULT); 436 (void) ficlDictionarySetPrimitive(dictionary, "fdepth", 437 ficlPrimitiveFDepth, FICL_WORD_DEFAULT); 438 (void) ficlDictionarySetPrimitive(dictionary, "fliteral", 439 ficlPrimitiveFLiteralImmediate, FICL_WORD_IMMEDIATE); 440 (void) ficlDictionarySetPrimitive(dictionary, "f.", 441 ficlPrimitiveFDot, FICL_WORD_DEFAULT); 442 (void) ficlDictionarySetPrimitive(dictionary, "f.s", 443 ficlVmDisplayFloatStack, FICL_WORD_DEFAULT); 444 (void) ficlDictionarySetPrimitive(dictionary, "fe.", 445 ficlPrimitiveEDot, FICL_WORD_DEFAULT); 446 447 /* 448 * Missing words: 449 * 450 * d>f 451 * f>d 452 * falign 453 * faligned 454 * float+ 455 * floats 456 * floor 457 * fmax 458 * fmin 459 */ 460 461 #if defined(_LP64) 462 data.f = MAXDOUBLE; 463 #else 464 data.f = MAXFLOAT; 465 #endif 466 (void) ficlDictionarySetConstant(environment, "max-float", data.i); 467 /* not all required words are present */ 468 (void) ficlDictionarySetConstant(environment, "floating", FICL_FALSE); 469 (void) ficlDictionarySetConstant(environment, "floating-ext", 470 FICL_FALSE); 471 (void) ficlDictionarySetConstant(environment, "floating-stack", 472 system->stackSize); 473 #else 474 (void) ficlDictionarySetConstant(environment, "floating", FICL_FALSE); 475 #endif 476 } 477