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: stable/11/stand/ficl/float.c 329175 2018-02-12 17:44:35Z kevans $ */ 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*******************************************************************/ 59static 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*******************************************************************/ 76static 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*******************************************************************/ 93static 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*******************************************************************/ 110static 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*******************************************************************/ 126static 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*******************************************************************/ 143static 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*******************************************************************/ 161static 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*******************************************************************/ 179static 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*******************************************************************/ 197static 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*******************************************************************/ 215static 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*******************************************************************/ 233static 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*******************************************************************/ 251static 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*******************************************************************/ 268static 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*******************************************************************/ 284void 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*******************************************************************/ 299static 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*******************************************************************/ 316static 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*******************************************************************/ 333static 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**************************************************************************/ 351static 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*******************************************************************/ 383static 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*******************************************************************/ 399static 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*******************************************************************/ 412static 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*******************************************************************/ 425static 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*******************************************************************/ 438static 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*******************************************************************/ 452static 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*******************************************************************/ 465static 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*******************************************************************/ 479static 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*******************************************************************/ 494static 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*******************************************************************/ 511static 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*******************************************************************/ 527static 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*******************************************************************/ 543static 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*******************************************************************/ 556static 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*******************************************************************/ 569static 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*******************************************************************/ 582static 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*******************************************************************/ 596static 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*******************************************************************/ 613static 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*******************************************************************/ 630static 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*******************************************************************/ 646static 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*******************************************************************/ 659static 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*******************************************************************/ 676static 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*******************************************************************/ 693static 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*******************************************************************/ 710static 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*******************************************************************/ 727static 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*******************************************************************/ 745static 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*******************************************************************/ 763static 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*******************************************************************/ 782static 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 796static 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 segement of a floating point number 814** being parsed. 815**************************************************************************/ 816#define NUMISNEG 1 817#define EXPISNEG 2 818 819typedef 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**************************************************************************/ 834int 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**************************************************************************/ 992void 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