sys/boot/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 /* $FreeBSD$ */
  45
  46 #include <stdlib.h>
  47 #include <stdio.h>
  48 #include <string.h>
  49 #include <ctype.h>
  50 #include <math.h>
  51 #include "ficl.h"
  52
  53 #if FICL_WANT_FLOAT
  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 segement 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