stand/ficl/float.c

   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