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