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 /* FALLTHROUGH */ 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 /* FALLTHROUGH */ 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 system 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 } 475