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.8 2001/12/05 07:21:34 jsadler 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 45 #include "ficl.h" 46 47 #if FICL_WANT_FLOAT 48 #include <stdlib.h> 49 #include <stdio.h> 50 #include <string.h> 51 #include <ctype.h> 52 #include <math.h> 53 54 /******************************************************************* 55 ** Do float addition r1 + r2. 56 ** f+ ( r1 r2 -- r ) 57 *******************************************************************/ 58 static void Fadd(FICL_VM *pVM) 59 { 60 FICL_FLOAT f; 61 62 #if FICL_ROBUST > 1 63 vmCheckFStack(pVM, 2, 1); 64 #endif 65 66 f = POPFLOAT(); 67 f += GETTOPF().f; 68 SETTOPF(f); 69 } 70 71 /******************************************************************* 72 ** Do float subtraction r1 - r2. 73 ** f- ( r1 r2 -- r ) 74 *******************************************************************/ 75 static void Fsub(FICL_VM *pVM) 76 { 77 FICL_FLOAT f; 78 79 #if FICL_ROBUST > 1 80 vmCheckFStack(pVM, 2, 1); 81 #endif 82 83 f = POPFLOAT(); 84 f = GETTOPF().f - f; 85 SETTOPF(f); 86 } 87 88 /******************************************************************* 89 ** Do float multiplication r1 * r2. 90 ** f* ( r1 r2 -- r ) 91 *******************************************************************/ 92 static void Fmul(FICL_VM *pVM) 93 { 94 FICL_FLOAT f; 95 96 #if FICL_ROBUST > 1 97 vmCheckFStack(pVM, 2, 1); 98 #endif 99 100 f = POPFLOAT(); 101 f *= GETTOPF().f; 102 SETTOPF(f); 103 } 104 105 /******************************************************************* 106 ** Do float negation. 107 ** fnegate ( r -- r ) 108 *******************************************************************/ 109 static void Fnegate(FICL_VM *pVM) 110 { 111 FICL_FLOAT f; 112 113 #if FICL_ROBUST > 1 114 vmCheckFStack(pVM, 1, 1); 115 #endif 116 117 f = -GETTOPF().f; 118 SETTOPF(f); 119 } 120 121 /******************************************************************* 122 ** Do float division r1 / r2. 123 ** f/ ( r1 r2 -- r ) 124 *******************************************************************/ 125 static void Fdiv(FICL_VM *pVM) 126 { 127 FICL_FLOAT f; 128 129 #if FICL_ROBUST > 1 130 vmCheckFStack(pVM, 2, 1); 131 #endif 132 133 f = POPFLOAT(); 134 f = GETTOPF().f / f; 135 SETTOPF(f); 136 } 137 138 /******************************************************************* 139 ** Do float + integer r + n. 140 ** f+i ( r n -- r ) 141 *******************************************************************/ 142 static void Faddi(FICL_VM *pVM) 143 { 144 FICL_FLOAT f; 145 146 #if FICL_ROBUST > 1 147 vmCheckFStack(pVM, 1, 1); 148 vmCheckStack(pVM, 1, 0); 149 #endif 150 151 f = (FICL_FLOAT)POPINT(); 152 f += GETTOPF().f; 153 SETTOPF(f); 154 } 155 156 /******************************************************************* 157 ** Do float - integer r - n. 158 ** f-i ( r n -- r ) 159 *******************************************************************/ 160 static void Fsubi(FICL_VM *pVM) 161 { 162 FICL_FLOAT f; 163 164 #if FICL_ROBUST > 1 165 vmCheckFStack(pVM, 1, 1); 166 vmCheckStack(pVM, 1, 0); 167 #endif 168 169 f = GETTOPF().f; 170 f -= (FICL_FLOAT)POPINT(); 171 SETTOPF(f); 172 } 173 174 /******************************************************************* 175 ** Do float * integer r * n. 176 ** f*i ( r n -- r ) 177 *******************************************************************/ 178 static void Fmuli(FICL_VM *pVM) 179 { 180 FICL_FLOAT f; 181 182 #if FICL_ROBUST > 1 183 vmCheckFStack(pVM, 1, 1); 184 vmCheckStack(pVM, 1, 0); 185 #endif 186 187 f = (FICL_FLOAT)POPINT(); 188 f *= GETTOPF().f; 189 SETTOPF(f); 190 } 191 192 /******************************************************************* 193 ** Do float / integer r / n. 194 ** f/i ( r n -- r ) 195 *******************************************************************/ 196 static void Fdivi(FICL_VM *pVM) 197 { 198 FICL_FLOAT f; 199 200 #if FICL_ROBUST > 1 201 vmCheckFStack(pVM, 1, 1); 202 vmCheckStack(pVM, 1, 0); 203 #endif 204 205 f = GETTOPF().f; 206 f /= (FICL_FLOAT)POPINT(); 207 SETTOPF(f); 208 } 209 210 /******************************************************************* 211 ** Do integer - float n - r. 212 ** i-f ( n r -- r ) 213 *******************************************************************/ 214 static void isubf(FICL_VM *pVM) 215 { 216 FICL_FLOAT f; 217 218 #if FICL_ROBUST > 1 219 vmCheckFStack(pVM, 1, 1); 220 vmCheckStack(pVM, 1, 0); 221 #endif 222 223 f = (FICL_FLOAT)POPINT(); 224 f -= GETTOPF().f; 225 SETTOPF(f); 226 } 227 228 /******************************************************************* 229 ** Do integer / float n / r. 230 ** i/f ( n r -- r ) 231 *******************************************************************/ 232 static void idivf(FICL_VM *pVM) 233 { 234 FICL_FLOAT f; 235 236 #if FICL_ROBUST > 1 237 vmCheckFStack(pVM, 1,1); 238 vmCheckStack(pVM, 1, 0); 239 #endif 240 241 f = (FICL_FLOAT)POPINT(); 242 f /= GETTOPF().f; 243 SETTOPF(f); 244 } 245 246 /******************************************************************* 247 ** Do integer to float conversion. 248 ** int>float ( n -- r ) 249 *******************************************************************/ 250 static void itof(FICL_VM *pVM) 251 { 252 float f; 253 254 #if FICL_ROBUST > 1 255 vmCheckStack(pVM, 1, 0); 256 vmCheckFStack(pVM, 0, 1); 257 #endif 258 259 f = (float)POPINT(); 260 PUSHFLOAT(f); 261 } 262 263 /******************************************************************* 264 ** Do float to integer conversion. 265 ** float>int ( r -- n ) 266 *******************************************************************/ 267 static void Ftoi(FICL_VM *pVM) 268 { 269 FICL_INT i; 270 271 #if FICL_ROBUST > 1 272 vmCheckStack(pVM, 0, 1); 273 vmCheckFStack(pVM, 1, 0); 274 #endif 275 276 i = (FICL_INT)POPFLOAT(); 277 PUSHINT(i); 278 } 279 280 /******************************************************************* 281 ** Floating point constant execution word. 282 *******************************************************************/ 283 void FconstantParen(FICL_VM *pVM) 284 { 285 FICL_WORD *pFW = pVM->runningWord; 286 287 #if FICL_ROBUST > 1 288 vmCheckFStack(pVM, 0, 1); 289 #endif 290 291 PUSHFLOAT(pFW->param[0].f); 292 } 293 294 /******************************************************************* 295 ** Create a floating point constant. 296 ** fconstant ( r -"name"- ) 297 *******************************************************************/ 298 static void Fconstant(FICL_VM *pVM) 299 { 300 FICL_DICT *dp = vmGetDict(pVM); 301 STRINGINFO si = vmGetWord(pVM); 302 303 #if FICL_ROBUST > 1 304 vmCheckFStack(pVM, 1, 0); 305 #endif 306 307 dictAppendWord2(dp, si, FconstantParen, FW_DEFAULT); 308 dictAppendCell(dp, stackPop(pVM->fStack)); 309 } 310 311 /******************************************************************* 312 ** Display a float in decimal format. 313 ** f. ( r -- ) 314 *******************************************************************/ 315 static void FDot(FICL_VM *pVM) 316 { 317 float f; 318 319 #if FICL_ROBUST > 1 320 vmCheckFStack(pVM, 1, 0); 321 #endif 322 323 f = POPFLOAT(); 324 sprintf(pVM->pad,"%#f ",f); 325 vmTextOut(pVM, pVM->pad, 0); 326 } 327 328 /******************************************************************* 329 ** Display a float in engineering format. 330 ** fe. ( r -- ) 331 *******************************************************************/ 332 static void EDot(FICL_VM *pVM) 333 { 334 float f; 335 336 #if FICL_ROBUST > 1 337 vmCheckFStack(pVM, 1, 0); 338 #endif 339 340 f = POPFLOAT(); 341 sprintf(pVM->pad,"%#e ",f); 342 vmTextOut(pVM, pVM->pad, 0); 343 } 344 345 /************************************************************************** 346 d i s p l a y FS t a c k 347 ** Display the parameter stack (code for "f.s") 348 ** f.s ( -- ) 349 **************************************************************************/ 350 static void displayFStack(FICL_VM *pVM) 351 { 352 int d = stackDepth(pVM->fStack); 353 int i; 354 CELL *pCell; 355 356 vmCheckFStack(pVM, 0, 0); 357 358 vmTextOut(pVM, "F:", 0); 359 360 if (d == 0) 361 vmTextOut(pVM, "[0]", 0); 362 else 363 { 364 ltoa(d, &pVM->pad[1], pVM->base); 365 pVM->pad[0] = '['; 366 strcat(pVM->pad,"] "); 367 vmTextOut(pVM,pVM->pad,0); 368 369 pCell = pVM->fStack->sp - d; 370 for (i = 0; i < d; i++) 371 { 372 sprintf(pVM->pad,"%#f ",(*pCell++).f); 373 vmTextOut(pVM,pVM->pad,0); 374 } 375 } 376 } 377 378 /******************************************************************* 379 ** Do float stack depth. 380 ** fdepth ( -- n ) 381 *******************************************************************/ 382 static void Fdepth(FICL_VM *pVM) 383 { 384 int i; 385 386 #if FICL_ROBUST > 1 387 vmCheckStack(pVM, 0, 1); 388 #endif 389 390 i = stackDepth(pVM->fStack); 391 PUSHINT(i); 392 } 393 394 /******************************************************************* 395 ** Do float stack drop. 396 ** fdrop ( r -- ) 397 *******************************************************************/ 398 static void Fdrop(FICL_VM *pVM) 399 { 400 #if FICL_ROBUST > 1 401 vmCheckFStack(pVM, 1, 0); 402 #endif 403 404 DROPF(1); 405 } 406 407 /******************************************************************* 408 ** Do float stack 2drop. 409 ** f2drop ( r r -- ) 410 *******************************************************************/ 411 static void FtwoDrop(FICL_VM *pVM) 412 { 413 #if FICL_ROBUST > 1 414 vmCheckFStack(pVM, 2, 0); 415 #endif 416 417 DROPF(2); 418 } 419 420 /******************************************************************* 421 ** Do float stack dup. 422 ** fdup ( r -- r r ) 423 *******************************************************************/ 424 static void Fdup(FICL_VM *pVM) 425 { 426 #if FICL_ROBUST > 1 427 vmCheckFStack(pVM, 1, 2); 428 #endif 429 430 PICKF(0); 431 } 432 433 /******************************************************************* 434 ** Do float stack 2dup. 435 ** f2dup ( r1 r2 -- r1 r2 r1 r2 ) 436 *******************************************************************/ 437 static void FtwoDup(FICL_VM *pVM) 438 { 439 #if FICL_ROBUST > 1 440 vmCheckFStack(pVM, 2, 4); 441 #endif 442 443 PICKF(1); 444 PICKF(1); 445 } 446 447 /******************************************************************* 448 ** Do float stack over. 449 ** fover ( r1 r2 -- r1 r2 r1 ) 450 *******************************************************************/ 451 static void Fover(FICL_VM *pVM) 452 { 453 #if FICL_ROBUST > 1 454 vmCheckFStack(pVM, 2, 3); 455 #endif 456 457 PICKF(1); 458 } 459 460 /******************************************************************* 461 ** Do float stack 2over. 462 ** f2over ( r1 r2 r3 -- r1 r2 r3 r1 r2 ) 463 *******************************************************************/ 464 static void FtwoOver(FICL_VM *pVM) 465 { 466 #if FICL_ROBUST > 1 467 vmCheckFStack(pVM, 4, 6); 468 #endif 469 470 PICKF(3); 471 PICKF(3); 472 } 473 474 /******************************************************************* 475 ** Do float stack pick. 476 ** fpick ( n -- r ) 477 *******************************************************************/ 478 static void Fpick(FICL_VM *pVM) 479 { 480 CELL c = POP(); 481 482 #if FICL_ROBUST > 1 483 vmCheckFStack(pVM, c.i+1, c.i+2); 484 #endif 485 486 PICKF(c.i); 487 } 488 489 /******************************************************************* 490 ** Do float stack ?dup. 491 ** f?dup ( r -- r ) 492 *******************************************************************/ 493 static void FquestionDup(FICL_VM *pVM) 494 { 495 CELL c; 496 497 #if FICL_ROBUST > 1 498 vmCheckFStack(pVM, 1, 2); 499 #endif 500 501 c = GETTOPF(); 502 if (c.f != 0) 503 PICKF(0); 504 } 505 506 /******************************************************************* 507 ** Do float stack roll. 508 ** froll ( n -- ) 509 *******************************************************************/ 510 static void Froll(FICL_VM *pVM) 511 { 512 int i = POP().i; 513 i = (i > 0) ? i : 0; 514 515 #if FICL_ROBUST > 1 516 vmCheckFStack(pVM, i+1, i+1); 517 #endif 518 519 ROLLF(i); 520 } 521 522 /******************************************************************* 523 ** Do float stack -roll. 524 ** f-roll ( n -- ) 525 *******************************************************************/ 526 static void FminusRoll(FICL_VM *pVM) 527 { 528 int i = POP().i; 529 i = (i > 0) ? i : 0; 530 531 #if FICL_ROBUST > 1 532 vmCheckFStack(pVM, i+1, i+1); 533 #endif 534 535 ROLLF(-i); 536 } 537 538 /******************************************************************* 539 ** Do float stack rot. 540 ** frot ( r1 r2 r3 -- r2 r3 r1 ) 541 *******************************************************************/ 542 static void Frot(FICL_VM *pVM) 543 { 544 #if FICL_ROBUST > 1 545 vmCheckFStack(pVM, 3, 3); 546 #endif 547 548 ROLLF(2); 549 } 550 551 /******************************************************************* 552 ** Do float stack -rot. 553 ** f-rot ( r1 r2 r3 -- r3 r1 r2 ) 554 *******************************************************************/ 555 static void Fminusrot(FICL_VM *pVM) 556 { 557 #if FICL_ROBUST > 1 558 vmCheckFStack(pVM, 3, 3); 559 #endif 560 561 ROLLF(-2); 562 } 563 564 /******************************************************************* 565 ** Do float stack swap. 566 ** fswap ( r1 r2 -- r2 r1 ) 567 *******************************************************************/ 568 static void Fswap(FICL_VM *pVM) 569 { 570 #if FICL_ROBUST > 1 571 vmCheckFStack(pVM, 2, 2); 572 #endif 573 574 ROLLF(1); 575 } 576 577 /******************************************************************* 578 ** Do float stack 2swap 579 ** f2swap ( r1 r2 r3 r4 -- r3 r4 r1 r2 ) 580 *******************************************************************/ 581 static void FtwoSwap(FICL_VM *pVM) 582 { 583 #if FICL_ROBUST > 1 584 vmCheckFStack(pVM, 4, 4); 585 #endif 586 587 ROLLF(3); 588 ROLLF(3); 589 } 590 591 /******************************************************************* 592 ** Get a floating point number from a variable. 593 ** f@ ( n -- r ) 594 *******************************************************************/ 595 static void Ffetch(FICL_VM *pVM) 596 { 597 CELL *pCell; 598 599 #if FICL_ROBUST > 1 600 vmCheckFStack(pVM, 0, 1); 601 vmCheckStack(pVM, 1, 0); 602 #endif 603 604 pCell = (CELL *)POPPTR(); 605 PUSHFLOAT(pCell->f); 606 } 607 608 /******************************************************************* 609 ** Store a floating point number into a variable. 610 ** f! ( r n -- ) 611 *******************************************************************/ 612 static void Fstore(FICL_VM *pVM) 613 { 614 CELL *pCell; 615 616 #if FICL_ROBUST > 1 617 vmCheckFStack(pVM, 1, 0); 618 vmCheckStack(pVM, 1, 0); 619 #endif 620 621 pCell = (CELL *)POPPTR(); 622 pCell->f = POPFLOAT(); 623 } 624 625 /******************************************************************* 626 ** Add a floating point number to contents of a variable. 627 ** f+! ( r n -- ) 628 *******************************************************************/ 629 static void FplusStore(FICL_VM *pVM) 630 { 631 CELL *pCell; 632 633 #if FICL_ROBUST > 1 634 vmCheckStack(pVM, 1, 0); 635 vmCheckFStack(pVM, 1, 0); 636 #endif 637 638 pCell = (CELL *)POPPTR(); 639 pCell->f += POPFLOAT(); 640 } 641 642 /******************************************************************* 643 ** Floating point literal execution word. 644 *******************************************************************/ 645 static void fliteralParen(FICL_VM *pVM) 646 { 647 #if FICL_ROBUST > 1 648 vmCheckStack(pVM, 0, 1); 649 #endif 650 651 PUSHFLOAT(*(float*)(pVM->ip)); 652 vmBranchRelative(pVM, 1); 653 } 654 655 /******************************************************************* 656 ** Compile a floating point literal. 657 *******************************************************************/ 658 static void fliteralIm(FICL_VM *pVM) 659 { 660 FICL_DICT *dp = vmGetDict(pVM); 661 FICL_WORD *pfLitParen = ficlLookup(pVM->pSys, "(fliteral)"); 662 663 #if FICL_ROBUST > 1 664 vmCheckFStack(pVM, 1, 0); 665 #endif 666 667 dictAppendCell(dp, LVALUEtoCELL(pfLitParen)); 668 dictAppendCell(dp, stackPop(pVM->fStack)); 669 } 670 671 /******************************************************************* 672 ** Do float 0= comparison r = 0.0. 673 ** f0= ( r -- T/F ) 674 *******************************************************************/ 675 static void FzeroEquals(FICL_VM *pVM) 676 { 677 CELL c; 678 679 #if FICL_ROBUST > 1 680 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */ 681 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */ 682 #endif 683 684 c.i = FICL_BOOL(POPFLOAT() == 0); 685 PUSH(c); 686 } 687 688 /******************************************************************* 689 ** Do float 0< comparison r < 0.0. 690 ** f0< ( r -- T/F ) 691 *******************************************************************/ 692 static void FzeroLess(FICL_VM *pVM) 693 { 694 CELL c; 695 696 #if FICL_ROBUST > 1 697 vmCheckFStack(pVM, 1, 0); /* Make sure something on float stack. */ 698 vmCheckStack(pVM, 0, 1); /* Make sure room for result. */ 699 #endif 700 701 c.i = FICL_BOOL(POPFLOAT() < 0); 702 PUSH(c); 703 } 704 705 /******************************************************************* 706 ** Do float 0> comparison r > 0.0. 707 ** f0> ( r -- T/F ) 708 *******************************************************************/ 709 static void FzeroGreater(FICL_VM *pVM) 710 { 711 CELL c; 712 713 #if FICL_ROBUST > 1 714 vmCheckFStack(pVM, 1, 0); 715 vmCheckStack(pVM, 0, 1); 716 #endif 717 718 c.i = FICL_BOOL(POPFLOAT() > 0); 719 PUSH(c); 720 } 721 722 /******************************************************************* 723 ** Do float = comparison r1 = r2. 724 ** f= ( r1 r2 -- T/F ) 725 *******************************************************************/ 726 static void FisEqual(FICL_VM *pVM) 727 { 728 float x, y; 729 730 #if FICL_ROBUST > 1 731 vmCheckFStack(pVM, 2, 0); 732 vmCheckStack(pVM, 0, 1); 733 #endif 734 735 x = POPFLOAT(); 736 y = POPFLOAT(); 737 PUSHINT(FICL_BOOL(x == y)); 738 } 739 740 /******************************************************************* 741 ** Do float < comparison r1 < r2. 742 ** f< ( r1 r2 -- T/F ) 743 *******************************************************************/ 744 static void FisLess(FICL_VM *pVM) 745 { 746 float x, y; 747 748 #if FICL_ROBUST > 1 749 vmCheckFStack(pVM, 2, 0); 750 vmCheckStack(pVM, 0, 1); 751 #endif 752 753 y = POPFLOAT(); 754 x = POPFLOAT(); 755 PUSHINT(FICL_BOOL(x < y)); 756 } 757 758 /******************************************************************* 759 ** Do float > comparison r1 > r2. 760 ** f> ( r1 r2 -- T/F ) 761 *******************************************************************/ 762 static void FisGreater(FICL_VM *pVM) 763 { 764 float x, y; 765 766 #if FICL_ROBUST > 1 767 vmCheckFStack(pVM, 2, 0); 768 vmCheckStack(pVM, 0, 1); 769 #endif 770 771 y = POPFLOAT(); 772 x = POPFLOAT(); 773 PUSHINT(FICL_BOOL(x > y)); 774 } 775 776 777 /******************************************************************* 778 ** Move float to param stack (assumes they both fit in a single CELL) 779 ** f>s 780 *******************************************************************/ 781 static void FFrom(FICL_VM *pVM) 782 { 783 CELL c; 784 785 #if FICL_ROBUST > 1 786 vmCheckFStack(pVM, 1, 0); 787 vmCheckStack(pVM, 0, 1); 788 #endif 789 790 c = stackPop(pVM->fStack); 791 stackPush(pVM->pStack, c); 792 return; 793 } 794 795 static void ToF(FICL_VM *pVM) 796 { 797 CELL c; 798 799 #if FICL_ROBUST > 1 800 vmCheckFStack(pVM, 0, 1); 801 vmCheckStack(pVM, 1, 0); 802 #endif 803 804 c = stackPop(pVM->pStack); 805 stackPush(pVM->fStack, c); 806 return; 807 } 808 809 810 /************************************************************************** 811 F l o a t P a r s e S t a t e 812 ** Enum to determine the current segment of a floating point number 813 ** being parsed. 814 **************************************************************************/ 815 #define NUMISNEG 1 816 #define EXPISNEG 2 817 818 typedef enum _floatParseState 819 { 820 FPS_START, 821 FPS_ININT, 822 FPS_INMANT, 823 FPS_STARTEXP, 824 FPS_INEXP 825 } FloatParseState; 826 827 /************************************************************************** 828 f i c l P a r s e F l o a t N u m b e r 829 ** pVM -- Virtual Machine pointer. 830 ** si -- String to parse. 831 ** Returns 1 if successful, 0 if not. 832 **************************************************************************/ 833 int ficlParseFloatNumber( FICL_VM *pVM, STRINGINFO si ) 834 { 835 unsigned char ch, digit; 836 char *cp; 837 FICL_COUNT count; 838 float power; 839 float accum = 0.0f; 840 float mant = 0.1f; 841 FICL_INT exponent = 0; 842 char flag = 0; 843 FloatParseState estate = FPS_START; 844 845 #if FICL_ROBUST > 1 846 vmCheckFStack(pVM, 0, 1); 847 #endif 848 849 /* 850 ** floating point numbers only allowed in base 10 851 */ 852 if (pVM->base != 10) 853 return(0); 854 855 856 cp = SI_PTR(si); 857 count = (FICL_COUNT)SI_COUNT(si); 858 859 /* Loop through the string's characters. */ 860 while ((count--) && ((ch = *cp++) != 0)) 861 { 862 switch (estate) 863 { 864 /* At start of the number so look for a sign. */ 865 case FPS_START: 866 { 867 estate = FPS_ININT; 868 if (ch == '-') 869 { 870 flag |= NUMISNEG; 871 break; 872 } 873 if (ch == '+') 874 { 875 break; 876 } 877 } /* Note! Drop through to FPS_ININT */ 878 /* 879 **Converting integer part of number. 880 ** Only allow digits, decimal and 'E'. 881 */ 882 case FPS_ININT: 883 { 884 if (ch == '.') 885 { 886 estate = FPS_INMANT; 887 } 888 else if ((ch == 'e') || (ch == 'E')) 889 { 890 estate = FPS_STARTEXP; 891 } 892 else 893 { 894 digit = (unsigned char)(ch - '0'); 895 if (digit > 9) 896 return(0); 897 898 accum = accum * 10 + digit; 899 900 } 901 break; 902 } 903 /* 904 ** Processing the fraction part of number. 905 ** Only allow digits and 'E' 906 */ 907 case FPS_INMANT: 908 { 909 if ((ch == 'e') || (ch == 'E')) 910 { 911 estate = FPS_STARTEXP; 912 } 913 else 914 { 915 digit = (unsigned char)(ch - '0'); 916 if (digit > 9) 917 return(0); 918 919 accum += digit * mant; 920 mant *= 0.1f; 921 } 922 break; 923 } 924 /* Start processing the exponent part of number. */ 925 /* Look for sign. */ 926 case FPS_STARTEXP: 927 { 928 estate = FPS_INEXP; 929 930 if (ch == '-') 931 { 932 flag |= EXPISNEG; 933 break; 934 } 935 else if (ch == '+') 936 { 937 break; 938 } 939 } /* Note! Drop through to FPS_INEXP */ 940 /* 941 ** Processing the exponent part of number. 942 ** Only allow digits. 943 */ 944 case FPS_INEXP: 945 { 946 digit = (unsigned char)(ch - '0'); 947 if (digit > 9) 948 return(0); 949 950 exponent = exponent * 10 + digit; 951 952 break; 953 } 954 } 955 } 956 957 /* If parser never made it to the exponent this is not a float. */ 958 if (estate < FPS_STARTEXP) 959 return(0); 960 961 /* Set the sign of the number. */ 962 if (flag & NUMISNEG) 963 accum = -accum; 964 965 /* If exponent is not 0 then adjust number by it. */ 966 if (exponent != 0) 967 { 968 /* Determine if exponent is negative. */ 969 if (flag & EXPISNEG) 970 { 971 exponent = -exponent; 972 } 973 /* power = 10^x */ 974 power = (float)pow(10.0, exponent); 975 accum *= power; 976 } 977 978 PUSHFLOAT(accum); 979 if (pVM->state == COMPILE) 980 fliteralIm(pVM); 981 982 return(1); 983 } 984 985 #endif /* FICL_WANT_FLOAT */ 986 987 /************************************************************************** 988 ** Add float words to a system's dictionary. 989 ** pSys -- Pointer to the FICL sytem to add float words to. 990 **************************************************************************/ 991 void ficlCompileFloat(FICL_SYSTEM *pSys) 992 { 993 FICL_DICT *dp = pSys->dp; 994 assert(dp); 995 996 #if FICL_WANT_FLOAT 997 dictAppendWord(dp, ">float", ToF, FW_DEFAULT); 998 /* d>f */ 999 dictAppendWord(dp, "f!", Fstore, FW_DEFAULT); 1000 dictAppendWord(dp, "f*", Fmul, FW_DEFAULT); 1001 dictAppendWord(dp, "f+", Fadd, FW_DEFAULT); 1002 dictAppendWord(dp, "f-", Fsub, FW_DEFAULT); 1003 dictAppendWord(dp, "f/", Fdiv, FW_DEFAULT); 1004 dictAppendWord(dp, "f0<", FzeroLess, FW_DEFAULT); 1005 dictAppendWord(dp, "f0=", FzeroEquals, FW_DEFAULT); 1006 dictAppendWord(dp, "f<", FisLess, FW_DEFAULT); 1007 /* 1008 f>d 1009 */ 1010 dictAppendWord(dp, "f@", Ffetch, FW_DEFAULT); 1011 /* 1012 falign 1013 faligned 1014 */ 1015 dictAppendWord(dp, "fconstant", Fconstant, FW_DEFAULT); 1016 dictAppendWord(dp, "fdepth", Fdepth, FW_DEFAULT); 1017 dictAppendWord(dp, "fdrop", Fdrop, FW_DEFAULT); 1018 dictAppendWord(dp, "fdup", Fdup, FW_DEFAULT); 1019 dictAppendWord(dp, "fliteral", fliteralIm, FW_IMMEDIATE); 1020 /* 1021 float+ 1022 floats 1023 floor 1024 fmax 1025 fmin 1026 */ 1027 dictAppendWord(dp, "f?dup", FquestionDup, FW_DEFAULT); 1028 dictAppendWord(dp, "f=", FisEqual, FW_DEFAULT); 1029 dictAppendWord(dp, "f>", FisGreater, FW_DEFAULT); 1030 dictAppendWord(dp, "f0>", FzeroGreater, FW_DEFAULT); 1031 dictAppendWord(dp, "f2drop", FtwoDrop, FW_DEFAULT); 1032 dictAppendWord(dp, "f2dup", FtwoDup, FW_DEFAULT); 1033 dictAppendWord(dp, "f2over", FtwoOver, FW_DEFAULT); 1034 dictAppendWord(dp, "f2swap", FtwoSwap, FW_DEFAULT); 1035 dictAppendWord(dp, "f+!", FplusStore, FW_DEFAULT); 1036 dictAppendWord(dp, "f+i", Faddi, FW_DEFAULT); 1037 dictAppendWord(dp, "f-i", Fsubi, FW_DEFAULT); 1038 dictAppendWord(dp, "f*i", Fmuli, FW_DEFAULT); 1039 dictAppendWord(dp, "f/i", Fdivi, FW_DEFAULT); 1040 dictAppendWord(dp, "int>float", itof, FW_DEFAULT); 1041 dictAppendWord(dp, "float>int", Ftoi, FW_DEFAULT); 1042 dictAppendWord(dp, "f.", FDot, FW_DEFAULT); 1043 dictAppendWord(dp, "f.s", displayFStack, FW_DEFAULT); 1044 dictAppendWord(dp, "fe.", EDot, FW_DEFAULT); 1045 dictAppendWord(dp, "fover", Fover, FW_DEFAULT); 1046 dictAppendWord(dp, "fnegate", Fnegate, FW_DEFAULT); 1047 dictAppendWord(dp, "fpick", Fpick, FW_DEFAULT); 1048 dictAppendWord(dp, "froll", Froll, FW_DEFAULT); 1049 dictAppendWord(dp, "frot", Frot, FW_DEFAULT); 1050 dictAppendWord(dp, "fswap", Fswap, FW_DEFAULT); 1051 dictAppendWord(dp, "i-f", isubf, FW_DEFAULT); 1052 dictAppendWord(dp, "i/f", idivf, FW_DEFAULT); 1053 1054 dictAppendWord(dp, "float>", FFrom, FW_DEFAULT); 1055 1056 dictAppendWord(dp, "f-roll", FminusRoll, FW_DEFAULT); 1057 dictAppendWord(dp, "f-rot", Fminusrot, FW_DEFAULT); 1058 dictAppendWord(dp, "(fliteral)", fliteralParen, FW_COMPILE); 1059 1060 ficlSetEnv(pSys, "floating", FICL_FALSE); /* not all required words are present */ 1061 ficlSetEnv(pSys, "floating-ext", FICL_FALSE); 1062 ficlSetEnv(pSys, "floating-stack", FICL_DEFAULT_STACK); 1063 #endif 1064 return; 1065 } 1066 1067