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