MSP430-FORTH/SD_430FR5994/DOUBLE.4TH

   1
   2     CODE ABORT_DOUBLE
   3     SUB #4,R15
   4     MOV R14,2(R15)
   5     MOV &$180E,R14
   6     BIT #$80,R14
   7     0<> IF MOV #0,R14 THEN
   8     MOV R14,0(R15)
   9     MOV &$180A,R14
  10     SUB #401,R14
  11     COLON
  12     $0D EMIT
  13     ABORT" FastForth V4.1 please!"
  14     ABORT" build FastForth with DOUBLE_INPUT addon!"
  15     RST_RET
  16     ;
  17
  18     ABORT_DOUBLE
  19
  20 ; -----------------------------------------------------
  21 ; DOUBLE.4th for MSP_EXP430FR5994
  22 ; -----------------------------------------------------
  23     [DEFINED] {DOUBLE}
  24     [IF] {DOUBLE} [THEN]
  25
  26     [UNDEFINED] {DOUBLE} [IF]
  27     MARKER {DOUBLE}
  28
  29 ; ------------------------------------------------------------------
  30 ; first we download the set of definitions we need (from CORE_ANS)
  31 ; ------------------------------------------------------------------
  32
  33     [UNDEFINED] >R [IF]
  34     CODE >R
  35     PUSH R14
  36     MOV @R15+,R14
  37     MOV @R13+,R0
  38     ENDCODE
  39     [THEN]
  40
  41     [UNDEFINED] R> [IF]
  42     CODE R>
  43     SUB #2,R15
  44     MOV R14,0(R15)
  45     MOV @R1+,R14
  46     MOV @R13+,R0
  47     ENDCODE
  48     [THEN]
  49
  50     [UNDEFINED] SWAP [IF]
  51     CODE SWAP
  52     MOV @R15,R10
  53     MOV R14,0(R15)
  54     MOV R10,R14
  55     MOV @R13+,R0
  56     ENDCODE
  57     [THEN]
  58
  59     [UNDEFINED] OVER [IF]
  60     CODE OVER
  61     MOV R14,-2(R15)
  62     MOV @R15,R14
  63     SUB #2,R15
  64     MOV @R13+,R0
  65     ENDCODE
  66     [THEN]
  67
  68     [UNDEFINED] ROT [IF]
  69     CODE ROT
  70     MOV @R15,R10
  71     MOV R14,0(R15)
  72     MOV 2(R15),R14
  73     MOV R10,2(R15)
  74     MOV @R13+,R0
  75     ENDCODE
  76     [THEN]
  77
  78     [UNDEFINED] - [IF]
  79     CODE -
  80     SUB @R15+,R14
  81     XOR #-1,R14
  82     ADD #1,R14
  83     MOV @R13+,R0
  84     ENDCODE
  85     [THEN]
  86
  87     [UNDEFINED] IF [IF]
  88     CODE IF
  89     SUB #2,R15
  90     MOV R14,0(R15)
  91     MOV &$1DBE,R14
  92     ADD #4,&$1DBE
  93     MOV #[THEN]+$52,0(R14)
  94     ADD #2,R14
  95     MOV @R13+,R0
  96     ENDCODE IMMEDIATE
  97
  98     CODE THEN
  99     MOV &$1DBE,0(R14)
 100     MOV @R15+,R14
 101     MOV @R13+,R0
 102     ENDCODE IMMEDIATE
 103     [THEN]
 104
 105     [UNDEFINED] ELSE [IF]
 106     CODE ELSE
 107     ADD #4,&$1DBE
 108     MOV &$1DBE,R10
 109     MOV #[THEN]+$58,-4(R10)
 110     MOV R10,0(R14)
 111     SUB #2,R10
 112     MOV R10,R14
 113     MOV @R13+,R0
 114     ENDCODE IMMEDIATE
 115     [THEN]
 116
 117     [UNDEFINED] TO [IF]
 118     CODE TO
 119     BIS #$200,R2
 120     MOV @R13+,R0
 121     ENDCODE
 122     [THEN]
 123
 124     [UNDEFINED] SPACE [IF]
 125     CODE SPACE
 126     SUB #2,R15
 127     MOV R14,0(R15)
 128     MOV #$20,R14
 129     MOV #EMIT,R0
 130     ENDCODE
 131     [THEN]
 132
 133     [UNDEFINED] SPACES [IF]
 134     CODE SPACES
 135     CMP #0,R14
 136     0<> IF
 137         PUSH R13
 138         BEGIN
 139             LO2HI
 140             SPACE
 141             HI2LO
 142             SUB #2,R13
 143             SUB #1,R14
 144         0= UNTIL
 145         MOV @R1+,R13
 146     THEN
 147     MOV @R15+,R14
 148     MOV @R13+,R0
 149     ENDCODE
 150     [THEN]
 151
 152     [UNDEFINED] 2@ [IF]
 153     CODE 2@
 154     SUB #2,R15
 155     MOV 2(R14),0(R15)
 156     MOV @R14,R14
 157     MOV @R13+,R0
 158     ENDCODE
 159     [THEN]
 160
 161     [UNDEFINED] 2! [IF]
 162     CODE 2!
 163     MOV @R15+,0(R14)
 164     MOV @R15+,2(R14)
 165     MOV @R15+,R14
 166     MOV @R13+,R0
 167     ENDCODE
 168     [THEN]
 169
 170     [UNDEFINED] 2DUP [IF]
 171     CODE 2DUP
 172     SUB #4,R15
 173     MOV R14,2(R15)
 174     MOV 4(R15),0(R15)
 175     MOV @R13+,R0
 176     ENDCODE
 177     [THEN]
 178
 179     [UNDEFINED] 2DROP [IF]
 180     CODE 2DROP
 181     ADD #2,R15
 182     MOV @R15+,R14
 183     MOV @R13+,R0
 184     ENDCODE
 185     [THEN]
 186
 187     [UNDEFINED] 2SWAP [IF]
 188     CODE 2SWAP
 189     MOV @R15,R10
 190     MOV 4(R15),0(R15)
 191     MOV R10,4(R15)
 192     MOV R14,R10
 193     MOV 2(R15),R14
 194     MOV R10,2(R15)
 195     MOV @R13+,R0
 196     ENDCODE
 197     [THEN]
 198
 199     [UNDEFINED] 2OVER [IF]
 200     CODE 2OVER
 201     SUB #4,R15
 202     MOV R14,2(R15)
 203     MOV 8(R15),0(R15)
 204     MOV 6(R15),R14
 205     MOV @R13+,R0
 206     ENDCODE
 207     [THEN]
 208
 209     [UNDEFINED] 2>R [IF]
 210     CODE 2>R
 211     PUSH @R15+
 212     PUSH R14
 213     MOV @R15+,R14
 214     MOV @R13+,R0
 215     ENDCODE
 216     [THEN]
 217
 218     [UNDEFINED] 2R@ [IF]
 219     CODE 2R@
 220     SUB #4,R15
 221     MOV R14,2(R15)
 222     MOV @R1,R14
 223     MOV 2(R1),0(R15)
 224     MOV @R13+,R0
 225     ENDCODE
 226     [THEN]
 227
 228     [UNDEFINED] 2R> [IF]
 229     CODE 2R>
 230     SUB #4,R15
 231     MOV R14,2(R15)
 232     MOV @R1+,R14
 233     MOV @R1+,0(R15)
 234     MOV @R13+,R0
 235     ENDCODE
 236     [THEN]
 237
 238 ; --------------------------
 239 ; end of definitions we need
 240 ; --------------------------
 241
 242 ; ===============================================
 243 ; DOUBLE word set
 244 ; ===============================================
 245
 246     [UNDEFINED] D. [IF]
 247     CODE D.
 248     MOV R14,R12
 249     MOV #U.+$0A,R0
 250     ENDCODE
 251     [THEN]
 252
 253     [UNDEFINED] 2ROT [IF]
 254     CODE 2ROT
 255     MOV 8(R15),R9
 256     MOV 6(R15),R8
 257     MOV 4(R15),8(R15)
 258     MOV 2(R15),6(R15)
 259     MOV @R15,4(R15)
 260     MOV R14,2(R15)
 261     MOV R9,0(R15)
 262     MOV R8,R14
 263     MOV @R13+,R0
 264     ENDCODE
 265     [THEN]
 266
 267     [UNDEFINED] D>S [IF]
 268     CODE D>S
 269     MOV @R15+,R14
 270     MOV @R13+,R0
 271     ENDCODE
 272     [THEN]
 273
 274     [UNDEFINED] D0= [IF]
 275
 276     CODE D0=
 277     ADD #2,R15
 278     CMP #0,R14
 279     MOV #0,R14
 280     0= IF
 281         CMP #0,-2(R15)
 282         0= IF
 283 BW1         MOV #-1,R14
 284         THEN
 285     THEN
 286 BW2 AND #-1,R14
 287     MOV @R13+,R0
 288     ENDCODE
 289
 290     CODE D0<
 291     ADD #2,R15
 292     CMP #0,R14
 293     MOV #0,R14
 294     S< ?GOTO BW1
 295     GOTO BW2
 296     ENDCODE
 297
 298     CODE D=
 299     ADD #6,R15
 300     CMP R14,-4(R15)
 301     MOV #0,R14
 302     0<> ?GOTO BW2
 303     CMP -6(R15),-2(R15)
 304     0= ?GOTO BW1
 305     GOTO BW2
 306     ENDCODE
 307
 308     CODE D<
 309     ADD #6,R15
 310     CMP R14,-4(R15)
 311     MOV #0,R14
 312     S< IF
 313 BW1     MOV #-1,R14
 314     THEN
 315 BW3 0<> ?GOTO BW2
 316     CMP -6(R15),-2(R15)
 317     U>= ?GOTO BW2
 318     U< ?GOTO BW1
 319     ENDCODE
 320
 321     CODE DU<
 322     ADD #6,R15
 323     CMP R14,-4(R15)
 324     MOV #0,R14
 325     U>= ?GOTO BW3
 326     U< ?GOTO BW1
 327     ENDCODE
 328     [THEN]
 329
 330     [UNDEFINED] D+ [IF]
 331     CODE D+
 332 BW1 ADD @R15+,2(R15)
 333     ADDC @R15+,R14
 334     MOV @R13+,R0
 335     ENDCODE
 336
 337     CODE M+
 338     SUB #2,R15
 339     CMP #0,R14
 340     MOV R14,0(R15)
 341     MOV #-1,R14
 342     0>= IF
 343         MOV #0,R14
 344     THEN
 345     GOTO BW1
 346     ENDCODE
 347     [THEN]
 348
 349     [UNDEFINED] D- [IF]
 350     CODE D-
 351     SUB @R15+,2(R15)
 352     SUBC R14,0(R15)
 353     MOV @R15+,R14
 354     MOV @R13+,R0
 355     ENDCODE
 356     [THEN]
 357
 358     [UNDEFINED] DNEGATE [IF]
 359     CODE DNEGATE
 360 BW1 XOR #-1,0(R15)
 361     XOR #-1,R14
 362     ADD #1,0(R15)
 363     ADDC #0,R14
 364     MOV @R13+,R0
 365     ENDCODE
 366
 367     CODE DABS
 368     CMP #0,R14
 369     0< ?GOTO BW1
 370     MOV @R13+,R0
 371     ENDCODE
 372     [THEN]
 373
 374     [UNDEFINED] D2/ [IF]
 375     CODE D2/
 376     RRA R14
 377     RRC 0(R15)
 378     MOV @R13+,R0
 379     ENDCODE
 380     [THEN]
 381
 382     [UNDEFINED] D2* [IF]
 383     CODE D2*
 384     ADD @R15,0(R15)
 385     ADDC R14,R14
 386     MOV @R13+,R0
 387     ENDCODE
 388     [THEN]
 389
 390     [UNDEFINED] DMAX [IF]
 391     : DMAX
 392     2OVER 2OVER
 393     D< IF
 394         2>R 2DROP 2R>
 395     ELSE
 396         2DROP
 397     THEN
 398     ;
 399     [THEN]
 400
 401     [UNDEFINED] DMIN [IF]
 402     : DMIN
 403     2OVER 2OVER
 404     D< IF
 405         2DROP
 406     ELSE
 407         2>R 2DROP 2R>
 408     THEN
 409     ;
 410     [THEN]
 411
 412     [UNDEFINED] M*/ [IF]
 413
 414     RST_SET
 415
 416     CODE TSTBIT
 417     MOV @R15+,R9
 418     AND @R9,R14
 419     MOV @R13+,R0
 420     ENDCODE
 421
 422     $180E $10 TSTBIT
 423
 424     RST_RET
 425
 426     [IF]   ; MSP430FRxxxx with hardware_MPY
 427
 428     CODE M*/
 429     MOV 4(R15),&$4D4
 430     MOV 2(R15),&$4D6
 431     MOV @R15+,&$4C8
 432     MOV R14,R11
 433     MOV R0,R0
 434     MOV &$4E4,R12
 435     MOV &$4E6,R14
 436     MOV &$4E8,R10
 437     MOV #0,R6
 438     CMP #0,R10
 439     S< IF
 440         XOR #-1,R12
 441         XOR #-1,R14
 442         XOR #-1,R10
 443         ADD #1,R12
 444         ADDC #0,R14
 445         ADDC #0,R10
 446         MOV #-1,R6
 447     THEN
 448
 449     [ELSE]  ; no hardware multiplier
 450
 451     CODE M*/
 452     MOV #0,R6
 453     CMP #0,2(R15)
 454     S< IF
 455         XOR #-1,4(R15)
 456         XOR #-1,2(R15)
 457         ADD #1,4(R15)
 458         ADDC #0,2(R15)
 459         MOV #-1,R6
 460     THEN
 461     CMP #0,0(R15)
 462     S< IF
 463         XOR #-1,0(R15)
 464         ADD #1,0(R15)
 465         XOR #-1,R6
 466     THEN
 467                 MOV 4(R15),R8
 468                 MOV 2(R15),R11
 469                 MOV #0,R5
 470                 MOV @R15+,R12
 471                 MOV #0,2(R15)
 472                 MOV #0,0(R15)
 473                 MOV #0,R10
 474                 MOV #1,R9
 475     BEGIN       BIT R9,R12
 476         0<> IF  ADD R8,2(R15)
 477                 ADDC R11,0(R15)
 478                 ADDC R5,R10
 479         THEN    ADD R8,R8
 480                 ADDC R11,R11
 481                 ADDC R5,R5
 482                 ADD R9,R9
 483     U>= UNTIL
 484     MOV R14,R11
 485     MOV @R15,R14
 486     MOV 2(R15),R12
 487
 488     [THEN]  ; endcase of software/hardware_MPY
 489
 490     MOV #32,R5
 491     CMP #0,R10
 492     0= IF
 493         MOV R14,R10
 494         CALL #<#+$1A
 495     ELSE
 496         CALL #<#+$22
 497     THEN
 498     MOV @R15+,0(R15)
 499     CMP #0,R6
 500     0<> IF
 501         XOR #-1,0(R15)
 502         XOR #-1,R14
 503         ADD #1,0(R15)
 504         ADDC #0,R14
 505         CMP #0,&$180E
 506         S< IF
 507             CMP #0,R10
 508             0<> IF
 509                 SUB #1,0(R15)
 510                 SUBC #0,R14
 511             THEN
 512         THEN
 513     THEN
 514     MOV #[THEN]+$5C,R5
 515     MOV #[THEN]+$6A,R6
 516     MOV @R13+,R0
 517     ENDCODE
 518     [THEN]
 519
 520     [UNDEFINED] 2VARIABLE [IF]
 521     : 2VARIABLE
 522     CREATE
 523     HI2LO
 524     ADD #4,&$1DBE
 525     MOV @R1+,R13
 526     MOV @R13+,R0
 527     ENDCODE
 528     [THEN]
 529
 530     [UNDEFINED] 2CONSTANT [IF]
 531     : 2CONSTANT
 532     CREATE
 533     , ,
 534     DOES>
 535     2@
 536     ;
 537     [THEN]
 538
 539     [UNDEFINED] 2VALUE [IF]
 540     : 2VALUE
 541     CREATE , ,
 542     DOES>
 543     HI2LO
 544     MOV @R1+,R13
 545     BIT #$200,R2
 546     0= IF
 547         MOV #2@,R0
 548     THEN
 549     BIC #$200,R2
 550     MOV #2!,R0
 551     ENDCODE
 552     [THEN]
 553
 554
 555     [UNDEFINED] 2LITERAL [IF]
 556     CODE 2LITERAL
 557     BIS #$200,R2
 558     MOV #LITERAL,R0
 559     ENDCODE IMMEDIATE
 560     [THEN]
 561
 562
 563     [UNDEFINED] D.R [IF]
 564     : D.R
 565     >R SWAP OVER DABS <# #S ROT SIGN #>
 566     R> OVER - SPACES TYPE
 567     ;
 568     [THEN]
 569
 570     RST_SET
 571
 572     [THEN]
 573
 574 ; -------------------------------
 575 ; Complement to pass DOUBLE TESTS
 576 ; -------------------------------
 577
 578     [UNDEFINED] R> [IF]
 579     CODE R>
 580     SUB #2,R15
 581     MOV R14,0(R15)
 582     MOV @R1+,R14
 583     MOV @R13+,R0
 584     ENDCODE
 585     [THEN]
 586
 587     [UNDEFINED] C@ [IF]
 588     CODE C@
 589     MOV.B @R14,R14
 590     MOV @R13+,R0
 591     ENDCODE
 592     [THEN]
 593
 594     [UNDEFINED] DUP [IF]
 595     CODE DUP
 596 BW1 SUB #2,R15
 597     MOV R14,0(R15)
 598     MOV @R13+,R0
 599     ENDCODE
 600
 601     CODE ?DUP
 602     CMP #0,R14
 603     0<> ?GOTO BW1
 604     MOV @R13+,R0
 605     ENDCODE
 606     [THEN]
 607
 608     [UNDEFINED] SWAP [IF]
 609     CODE SWAP
 610     MOV @R15,R10
 611     MOV R14,0(R15)
 612     MOV R10,R14
 613     MOV @R13+,R0
 614     ENDCODE
 615     [THEN]
 616
 617     [UNDEFINED] DROP [IF]
 618     CODE DROP
 619     MOV @R15+,R14
 620     MOV @R13+,R0
 621     ENDCODE
 622     [THEN]
 623
 624     [UNDEFINED] VARIABLE [IF]
 625     : VARIABLE
 626     CREATE
 627     HI2LO
 628     MOV #$1287,-4(R10)
 629     MOV @R1+,R13
 630     MOV @R13+,R0
 631     ENDCODE
 632     [THEN]
 633
 634     [UNDEFINED] CONSTANT [IF]
 635     : CONSTANT
 636     CREATE
 637     HI2LO
 638     MOV R14,-2(R10)
 639     MOV @R15+,R14
 640     MOV @R1+,R13
 641     MOV @R13+,R0
 642     ENDCODE
 643     [THEN]
 644
 645     [UNDEFINED] CELLS [IF]
 646     CODE CELLS
 647     ADD R14,R14
 648     MOV @R13+,R0
 649     ENDCODE
 650     [THEN]
 651
 652     [UNDEFINED] DEPTH [IF]
 653     CODE DEPTH
 654     MOV R14,-2(R15)
 655     MOV #$1C80,R14
 656     SUB R15,R14
 657     RRA R14
 658     SUB #2,R15
 659     MOV @R13+,R0
 660     ENDCODE
 661     [THEN]
 662
 663     [UNDEFINED] IF [IF]
 664     CODE IF
 665     SUB #2,R15
 666     MOV R14,0(R15)
 667     MOV &$1DBE,R14
 668     ADD #4,&$1DBE
 669     MOV #[THEN]+$52,0(R14)
 670     ADD #2,R14
 671     MOV @R13+,R0
 672     ENDCODE IMMEDIATE
 673
 674     CODE THEN
 675     MOV &$1DBE,0(R14)
 676     MOV @R15+,R14
 677     MOV @R13+,R0
 678     ENDCODE IMMEDIATE
 679     [THEN]
 680
 681     [UNDEFINED] ELSE [IF]
 682     CODE ELSE
 683     ADD #4,&$1DBE
 684     MOV &$1DBE,R10
 685     MOV #[THEN]+$58,-4(R10)
 686     MOV R10,0(R14)
 687     SUB #2,R10
 688     MOV R10,R14
 689     MOV @R13+,R0
 690     ENDCODE IMMEDIATE
 691     [THEN]
 692
 693     [UNDEFINED] DO [IF]
 694
 695     HDNCODE XDO
 696     MOV #$8000,R9
 697     SUB @R15+,R9
 698     MOV R14,R8
 699     ADD R9,R8
 700     PUSHM #2,R9
 701     MOV @R15+,R14
 702     MOV @R13+,R0
 703     ENDCODE
 704
 705     CODE DO
 706     SUB #2,R15
 707     MOV R14,0(R15)
 708     ADD #2,&$1DBE
 709     MOV &$1DBE,R14
 710     MOV #XDO,-2(R14)
 711     ADD #2,&$1C00
 712     MOV &$1C00,R10
 713     MOV #0,0(R10)
 714     MOV @R13+,R0
 715     ENDCODE IMMEDIATE
 716
 717     HDNCODE XLOOP
 718     ADD #1,0(R1)
 719 BW1 BIT #$100,R2
 720     0= IF
 721         MOV @R13,R13
 722         MOV @R13+,R0
 723     THEN
 724     ADD #4,R1
 725     ADD #2,R13
 726     MOV @R13+,R0
 727     ENDCODE
 728
 729     CODE LOOP
 730     MOV #XLOOP,R9
 731 BW2 ADD #4,&$1DBE
 732     MOV &$1DBE,R10
 733     MOV R9,-4(R10)
 734     MOV R14,-2(R10)
 735     BEGIN
 736         MOV &$1C00,R14
 737         SUB #2,&$1C00
 738         MOV @R14,R14
 739         CMP #0,R14
 740     0<> WHILE
 741         MOV R10,0(R14)
 742     REPEAT
 743     MOV @R15+,R14
 744     MOV @R13+,R0
 745     ENDCODE IMMEDIATE
 746
 747     HDNCODE XPLOO
 748     ADD R14,0(R1)
 749     MOV @R15+,R14
 750     GOTO BW1
 751     ENDCODE
 752
 753     CODE +LOOP
 754     MOV #XPLOO,R9
 755     GOTO BW2
 756     ENDCODE IMMEDIATE
 757     [THEN]
 758
 759     [UNDEFINED] I [IF]
 760     CODE I
 761     SUB #2,R15
 762     MOV R14,0(R15)
 763     MOV @R1,R14
 764     SUB 2(R1),R14
 765     MOV @R13+,R0
 766     ENDCODE
 767     [THEN]
 768
 769     [UNDEFINED] + [IF]
 770     CODE +
 771     ADD @R15+,R14
 772     MOV @R13+,R0
 773     ENDCODE
 774     [THEN]
 775
 776     [UNDEFINED] = [IF]
 777     CODE =
 778     SUB @R15+,R14
 779     0<> IF
 780         AND #0,R14
 781         MOV @R13+,R0
 782     THEN
 783     XOR #-1,R14
 784     MOV @R13+,R0
 785     ENDCODE
 786     [THEN]
 787
 788     [UNDEFINED] 0= [IF]
 789     CODE 0=
 790     SUB #1,R14
 791     SUBC R14,R14
 792     MOV @R13+,R0
 793     ENDCODE
 794     [THEN]
 795
 796     [UNDEFINED] 0< [IF]
 797     CODE 0<
 798     ADD R14,R14
 799     SUBC R14,R14
 800     XOR #-1,R14
 801     MOV @R13+,R0
 802     ENDCODE
 803     [THEN]
 804
 805     [UNDEFINED] SOURCE [IF]
 806     CODE SOURCE
 807     SUB #4,R15
 808     MOV R14,2(R15)
 809     MOV &$1DB8,R14
 810     MOV &$1DBA,0(R15)
 811     MOV @R13+,R0
 812     ENDCODE
 813     [THEN]
 814
 815     [UNDEFINED] >IN [IF]
 816     $1DBC CONSTANT >IN
 817     [THEN]
 818
 819     [UNDEFINED] 1+ [IF]
 820     CODE 1+
 821     ADD #1,R14
 822     MOV @R13+,R0
 823     ENDCODE
 824     [THEN]
 825
 826     [UNDEFINED] CHAR [IF]
 827     : CHAR
 828         $20 WORD 1+ C@
 829     ;
 830     [THEN]
 831
 832     [UNDEFINED] [CHAR] [IF]
 833     : [CHAR]
 834         CHAR POSTPONE LITERAL
 835     ; IMMEDIATE
 836     [THEN]
 837
 838     [UNDEFINED] 2/ [IF]
 839     CODE 2/
 840     RRA R14
 841     MOV @R13+,R0
 842     ENDCODE
 843     [THEN]
 844
 845     [UNDEFINED] INVERT [IF]
 846     CODE INVERT
 847     XOR #-1,R14
 848     MOV @R13+,R0
 849     ENDCODE
 850     [THEN]
 851
 852     [UNDEFINED] RSHIFT [IF]
 853     CODE RSHIFT
 854     MOV @R15+,R10
 855     AND #$1F,R14
 856     0<> IF
 857         BEGIN
 858             BIC #1,R2
 859             RRC R10
 860             SUB #1,R14
 861         0= UNTIL
 862     THEN
 863     MOV R10,R14
 864     MOV @R13+,R0
 865     ENDCODE
 866     [THEN]
 867
 868     [UNDEFINED] S>D [IF]
 869     : S>D
 870         DUP 0<
 871     ;
 872     [THEN]
 873
 874     [UNDEFINED] 1- [IF]
 875     CODE 1-
 876     SUB #1,R14
 877     MOV @R13+,R0
 878     ENDCODE
 879     [THEN]
 880
 881     [UNDEFINED] NEGATE [IF]
 882     CODE NEGATE
 883     XOR #-1,R14
 884     ADD #1,R14
 885     MOV @R13+,R0
 886     ENDCODE
 887     [THEN]
 888
 889     [UNDEFINED] HERE [IF]
 890     CODE HERE
 891     MOV #BEGIN,R0
 892     ENDCODE
 893     [THEN]
 894
 895     [UNDEFINED] CHARS [IF]
 896     CODE CHARS
 897     MOV @R13+,R0
 898     ENDCODE
 899     [THEN]
 900
 901     [UNDEFINED] MOVE [IF]
 902     CODE MOVE
 903     MOV R14,R10
 904     MOV @R15+,R8
 905     MOV @R15+,R9
 906     MOV @R15+,R14
 907     CMP #0,R10
 908     0<> IF
 909         CMP R9,R8
 910         0<> IF
 911             U< IF
 912                 BEGIN
 913                     MOV.B @R9+,0(R8)
 914                     ADD #1,R8
 915                     SUB #1,R10
 916                 0= UNTIL
 917                 MOV @R13+,R0
 918             THEN
 919             ADD R10,R8
 920             ADD R10,R9
 921             BEGIN
 922                 SUB #1,R9
 923                 SUB #1,R8
 924                 MOV.B @R9,0(R8)
 925                 SUB #1,R10
 926             0= UNTIL
 927         THEN
 928     THEN
 929     MOV @R13+,R0
 930     ENDCODE
 931     [THEN]
 932
 933     [UNDEFINED] DECIMAL [IF]
 934     CODE DECIMAL
 935     MOV #$0A,&$1DB6
 936     MOV @R13+,R0
 937     ENDCODE
 938     [THEN]
 939
 940     [UNDEFINED] BASE [IF]
 941     $1DB6 CONSTANT BASE
 942     [THEN]
 943
 944     [UNDEFINED] ( [IF]
 945     : (
 946     ')' WORD DROP
 947     ; IMMEDIATE
 948     [THEN]
 949
 950     [UNDEFINED] .( [IF] ; "
 951     CODE .(        ; "
 952     MOV #0,&CAPS
 953     COLON
 954     ')' WORD
 955     COUNT TYPE
 956     $20 CAPS !
 957     ; IMMEDIATE
 958     [THEN]
 959
 960     [UNDEFINED] CR [IF]
 961     CODE CR
 962     MOV #[THEN],R0
 963     ENDCODE
 964
 965     :NONAME
 966     $0D EMIT $0A EMIT
 967     ; IS CR
 968     [THEN]
 969
 970     $180E @ 0<  ; test the switch: FLOORED/SYMETRIC DIVISION
 971     [IF]
 972         [UNDEFINED] FM/MOD [IF]
 973         CODE FM/MOD
 974         MOV R14,R12
 975         MOV @R15,R11
 976         CMP #0,R14
 977         S< IF
 978             XOR #-1,R14
 979             ADD #1,R14
 980         THEN
 981         CMP #0,0(R15)
 982         S< IF
 983             XOR #-1,2(R15)
 984             XOR #-1,0(R15)
 985             ADD #1,2(R15)
 986             ADDC #0,0(R15)
 987         THEN
 988         PUSHM  #2,R12
 989         CALL #<#+8
 990         MOV @R15+,R14
 991         POPM  #2,R12
 992         CMP #0,R11
 993         S< IF
 994             XOR #-1,0(R15)
 995             ADD #1,0(R15)
 996         THEN
 997         XOR R12,R11
 998         CMP #0,R11
 999         S< IF
1000             XOR #-1,R14
1001             ADD #1,R14
1002         THEN
1003
1004         CMP #0,0(R15)
1005         0<> IF
1006             CMP #1,R14
1007             S< IF
1008             ADD R12,0(R15)
1009             SUB #1,R14
1010             THEN
1011         THEN
1012         MOV @R13+,R0
1013         ENDCODE
1014         [THEN]
1015     [ELSE]
1016         [UNDEFINED] SM/REM [IF]
1017         CODE SM/REM
1018         MOV R14,R12
1019         MOV @R15,R11
1020         CMP #0,R14
1021         S< IF
1022             XOR #-1,R14
1023             ADD #1,R14
1024         THEN
1025         CMP #0,0(R15)
1026         S< IF
1027             XOR #-1,2(R15)
1028             XOR #-1,0(R15)
1029             ADD #1,2(R15)
1030             ADDC #0,0(R15)
1031         THEN
1032         PUSHM  #2,R12
1033         CALL #<#+8
1034         MOV @R15+,R14
1035         POPM  #2,R12
1036         CMP #0,R11
1037         S< IF
1038             XOR #-1,0(R15)
1039             ADD #1,0(R15)
1040         THEN
1041         XOR R12,R11
1042         CMP #0,R11
1043         S< IF
1044             XOR #-1,R14
1045             ADD #1,R14
1046         THEN
1047         MOV @R13+,R0
1048         ENDCODE
1049         [THEN]
1050     [THEN]
1051
1052     [UNDEFINED] NIP [IF]
1053     CODE NIP
1054     ADD #2,R15
1055     MOV @R13+,R0
1056     ENDCODE
1057     [THEN]
1058
1059     [UNDEFINED] / [IF]
1060     : /
1061     >R DUP 0< R>
1062     [ $180E @ 0< ]
1063     [IF]    FM/MOD
1064     [ELSE]  SM/REM
1065     [THEN]
1066     NIP
1067     ;
1068     [THEN]
1069
1070
1071  0 CONSTANT FALSE
1072 -1 CONSTANT TRUE
1073
1074 VARIABLE VERBOSE
1075     FALSE VERBOSE !
1076
1077 VARIABLE ACTUAL-DEPTH
1078 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
1079
1080 : T{
1081     ;
1082
1083 : ->
1084     DEPTH DUP ACTUAL-DEPTH !
1085     ?DUP IF
1086         0 DO ACTUAL-RESULTS I CELLS + ! LOOP
1087     THEN ;
1088
1089 : }T
1090
1091     DEPTH ACTUAL-DEPTH @ = IF
1092         DEPTH ?DUP IF
1093         0 DO
1094             ACTUAL-RESULTS I CELLS + @
1095             = 0= IF TRUE ABORT" INCORRECT RESULT" THEN
1096         LOOP
1097         THEN
1098     ELSE
1099         TRUE ABORT" WRONG NUMBER OF RESULTS"
1100     THEN ;
1101
1102 : TESTING
1103     SOURCE VERBOSE @
1104     IF DUP >R TYPE CR R> >IN !
1105     ELSE >IN ! DROP [CHAR] * EMIT
1106     THEN ;
1107
1108
1109 DECIMAL
1110
1111 0 INVERT        CONSTANT 1SD
1112 1SD 1 RSHIFT    CONSTANT MAX-INTD
1113 MAX-INTD INVERT CONSTANT MIN-INTD
1114 MAX-INTD 2/     CONSTANT HI-INT
1115 MIN-INTD 2/     CONSTANT LO-INT
1116
1117
1118 ECHO
1119
1120 ; ----------------------------------------------------------------------------
1121 TESTING interpreter and compiler reading double numbers, with/without prefixes
1122
1123 T{ 1. -> 1 0 }T
1124 T{ -2. -> -2 -1 }T
1125 T{ : RDL1 3. ; RDL1 -> 3 0 }T
1126 T{ : RDL2 -4. ; RDL2 -> -4 -1 }T
1127
1128 VARIABLE OLD-DBASE
1129 DECIMAL BASE @ OLD-DBASE !
1130 T{ #12346789. -> 12346789. }T
1131 T{ #-12346789. -> -12346789. }T
1132 T{ $12aBcDeF. -> 313249263. }T
1133 T{ $-12AbCdEf. -> -313249263. }T
1134 T{ %10010110. -> 150. }T
1135 T{ %-10010110. -> -150. }T
1136 ; Check BASE is unchanged
1137 T{ BASE @ OLD-DBASE @ = -> TRUE }T
1138
1139 ; Repeat in Hex mode
1140 16 OLD-DBASE ! 16 BASE !
1141 T{ #12346789. -> BC65A5. }T
1142 T{ #-12346789. -> -BC65A5. }T
1143 T{ $12aBcDeF. -> 12AbCdeF. }T
1144 T{ $-12AbCdEf. -> -12ABCDef. }T
1145 T{ %10010110. -> 96. }T
1146 T{ %-10010110. -> -96. }T
1147 ; Check BASE is unchanged
1148 T{ BASE @ OLD-DBASE @ = -> TRUE }T
1149
1150 DECIMAL
1151 ; Check number prefixes in compile mode
1152 T{ : dnmp  #8327. $-2cbe. %011010111. ; dnmp -> 8327. -11454. 215. }T
1153
1154 ; ----------------------------------------------------------------------------
1155 TESTING 2CONSTANT
1156
1157 T{ 1 2 2CONSTANT 2C1 -> }T
1158 T{ 2C1 -> 1 2 }T
1159 T{ : CD1 2C1 ; -> }T
1160 T{ CD1 -> 1 2 }T
1161 T{ : CD2 2CONSTANT ; -> }T
1162 T{ -1 -2 CD2 2C2 -> }T
1163 T{ 2C2 -> -1 -2 }T
1164 T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T
1165 T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T
1166
1167 ; ----------------------------------------------------------------------------
1168 ; Some 2CONSTANTs for the following tests
1169
1170 1SD MAX-INTD 2CONSTANT MAX-2INT
1171 0   MIN-INTD 2CONSTANT MIN-2INT
1172 MAX-2INT 2/  2CONSTANT HI-2INT
1173 MIN-2INT 2/  2CONSTANT LO-2INT
1174
1175 ; ----------------------------------------------------------------------------
1176 TESTING DNEGATE
1177
1178 T{ 0. DNEGATE -> 0. }T
1179 T{ 1. DNEGATE -> -1. }T
1180 T{ -1. DNEGATE -> 1. }T
1181 T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T
1182 T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T
1183
1184 ; ----------------------------------------------------------------------------
1185 TESTING D+ with small integers
1186
1187 T{  0.  5. D+ ->  5. }T
1188 T{ -5.  0. D+ -> -5. }T
1189 T{  1.  2. D+ ->  3. }T
1190 T{  1. -2. D+ -> -1. }T
1191 T{ -1.  2. D+ ->  1. }T
1192 T{ -1. -2. D+ -> -3. }T
1193 T{ -1.  1. D+ ->  0. }T
1194
1195 TESTING D+ with mid range integers
1196
1197 T{  0  0  0  5 D+ ->  0  5 }T
1198 T{ -1  5  0  0 D+ -> -1  5 }T
1199 T{  0  0  0 -5 D+ ->  0 -5 }T
1200 T{  0 -5 -1  0 D+ -> -1 -5 }T
1201 T{  0  1  0  2 D+ ->  0  3 }T
1202 T{ -1  1  0 -2 D+ -> -1 -1 }T
1203 T{  0 -1  0  2 D+ ->  0  1 }T
1204 T{  0 -1 -1 -2 D+ -> -1 -3 }T
1205 T{ -1 -1  0  1 D+ -> -1  0 }T
1206 T{ MIN-INTD 0 2DUP D+ -> 0 1 }T
1207 T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T
1208
1209 TESTING D+ with large double integers
1210
1211 T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T
1212 T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T
1213 T{ MAX-2INT MIN-2INT D+ -> -1. }T
1214 T{ MAX-2INT LO-2INT D+ -> HI-2INT }T
1215 T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T
1216 T{ LO-2INT 2DUP D+ -> MIN-2INT }T
1217
1218 ; ----------------------------------------------------------------------------
1219 TESTING D- with small integers
1220
1221 T{  0.  5. D- -> -5. }T
1222 T{  5.  0. D- ->  5. }T
1223 T{  0. -5. D- ->  5. }T
1224 T{  1.  2. D- -> -1. }T
1225 T{  1. -2. D- ->  3. }T
1226 T{ -1.  2. D- -> -3. }T
1227 T{ -1. -2. D- ->  1. }T
1228 T{ -1. -1. D- ->  0. }T
1229
1230 TESTING D- with mid-range integers
1231
1232 T{  0  0  0  5 D- ->  0 -5 }T
1233 T{ -1  5  0  0 D- -> -1  5 }T
1234 T{  0  0 -1 -5 D- ->  1  4 }T
1235 T{  0 -5  0  0 D- ->  0 -5 }T
1236 T{ -1  1  0  2 D- -> -1 -1 }T
1237 T{  0  1 -1 -2 D- ->  1  2 }T
1238 T{  0 -1  0  2 D- ->  0 -3 }T
1239 T{  0 -1  0 -2 D- ->  0  1 }T
1240 T{  0  0  0  1 D- ->  0 -1 }T
1241 T{ MIN-INTD 0 2DUP D- -> 0. }T
1242 T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T
1243
1244 TESTING D- with large integers
1245
1246 T{ MAX-2INT MAX-2INT D- -> 0. }T
1247 T{ MIN-2INT MIN-2INT D- -> 0. }T
1248 T{ MAX-2INT HI-2INT  D- -> LO-2INT DNEGATE }T
1249 T{ HI-2INT  LO-2INT  D- -> MAX-2INT }T
1250 T{ LO-2INT  HI-2INT  D- -> MIN-2INT 1. D+ }T
1251 T{ MIN-2INT MIN-2INT D- -> 0. }T
1252 T{ MIN-2INT LO-2INT  D- -> LO-2INT }T
1253
1254 ; ----------------------------------------------------------------------------
1255 TESTING D0< D0=
1256
1257 T{ 0. D0< -> FALSE }T
1258 T{ 1. D0< -> FALSE }T
1259 T{ MIN-INTD 0 D0< -> FALSE }T
1260 T{ 0 MAX-INTD D0< -> FALSE }T
1261 T{ MAX-2INT  D0< -> FALSE }T
1262 T{ -1. D0< -> TRUE }T
1263 T{ MIN-2INT D0< -> TRUE }T
1264
1265 T{ 1. D0= -> FALSE }T
1266 T{ MIN-INTD 0 D0= -> FALSE }T
1267 T{ MAX-2INT  D0= -> FALSE }T
1268 T{ -1 MAX-INTD D0= -> FALSE }T
1269 T{ 0. D0= -> TRUE }T
1270 T{ -1. D0= -> FALSE }T
1271 T{ 0 MIN-INTD D0= -> FALSE }T
1272
1273 ; ----------------------------------------------------------------------------
1274 TESTING D2* D2/
1275
1276 T{ 0. D2* -> 0. D2* }T
1277 T{ MIN-INTD 0 D2* -> 0 1 }T
1278 T{ HI-2INT D2* -> MAX-2INT 1. D- }T
1279 T{ LO-2INT D2* -> MIN-2INT }T
1280
1281 T{ 0. D2/ -> 0. }T
1282 T{ 1. D2/ -> 0. }T
1283 T{ 0 1 D2/ -> MIN-INTD 0 }T
1284 T{ MAX-2INT D2/ -> HI-2INT }T
1285 T{ -1. D2/ -> -1. }T
1286 T{ MIN-2INT D2/ -> LO-2INT }T
1287
1288 ; ----------------------------------------------------------------------------
1289 TESTING D< D=
1290
1291 T{  0.  1. D< -> TRUE  }T
1292 T{  0.  0. D< -> FALSE }T
1293 T{  1.  0. D< -> FALSE }T
1294 T{ -1.  1. D< -> TRUE  }T
1295 T{ -1.  0. D< -> TRUE  }T
1296 T{ -2. -1. D< -> TRUE  }T
1297 T{ -1. -2. D< -> FALSE }T
1298 T{ 0 1   1. D< -> FALSE }T
1299 T{ 1.  0 1  D< -> TRUE  }T
1300 T{ 0 -1 1 -2 D< -> FALSE }T
1301 T{ 1 -2 0 -1 D< -> TRUE  }T
1302 T{ -1. MAX-2INT D< -> TRUE }T
1303 T{ MIN-2INT MAX-2INT D< -> TRUE }T
1304 T{ MAX-2INT -1. D< -> FALSE }T
1305 T{ MAX-2INT MIN-2INT D< -> FALSE }T
1306 T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T
1307 T{ MIN-2INT 2DUP  1. D+ D< -> TRUE  }T
1308 T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T
1309
1310 T{ -1. -1. D= -> TRUE  }T
1311 T{ -1.  0. D= -> FALSE }T
1312 T{ -1.  1. D= -> FALSE }T
1313 T{  0. -1. D= -> FALSE }T
1314 T{  0.  0. D= -> TRUE  }T
1315 T{  0.  1. D= -> FALSE }T
1316 T{  1. -1. D= -> FALSE }T
1317 T{  1.  0. D= -> FALSE }T
1318 T{  1.  1. D= -> TRUE  }T
1319
1320 T{ 0 -1 0 -1 D= -> TRUE  }T
1321 T{ 0 -1 0  0 D= -> FALSE }T
1322 T{ 0 -1 0  1 D= -> FALSE }T
1323 T{ 0  0 0 -1 D= -> FALSE }T
1324 T{ 0  0 0  0 D= -> TRUE  }T
1325 T{ 0  0 0  1 D= -> FALSE }T
1326 T{ 0  1 0 -1 D= -> FALSE }T
1327 T{ 0  1 0  0 D= -> FALSE }T
1328 T{ 0  1 0  1 D= -> TRUE  }T
1329
1330 T{ MAX-2INT MIN-2INT D= -> FALSE }T
1331 T{ MAX-2INT 0. D= -> FALSE }T
1332 T{ MAX-2INT MAX-2INT D= -> TRUE }T
1333 T{ MAX-2INT HI-2INT  D= -> FALSE }T
1334 T{ MAX-2INT MIN-2INT D= -> FALSE }T
1335 T{ MIN-2INT MIN-2INT D= -> TRUE }T
1336 T{ MIN-2INT LO-2INT  D=  -> FALSE }T
1337 T{ MIN-2INT MAX-2INT D= -> FALSE }T
1338
1339 ; ----------------------------------------------------------------------------
1340 TESTING 2LITERAL 2VARIABLE
1341
1342 T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T
1343 T{ CD3 -> MAX-2INT }T
1344 T{ 2VARIABLE 2V1 -> }T
1345 T{ 0. 2V1 2! -> }T
1346 T{ 2V1 2@ -> 0. }T
1347 T{ -1 -2 2V1 2! -> }T
1348 T{ 2V1 2@ -> -1 -2 }T
1349 T{ : CD4 2VARIABLE ; -> }T
1350 T{ CD4 2V2 -> }T
1351 T{ : CD5 2V2 2! ; -> }T
1352 T{ -2 -1 CD5 -> }T
1353 T{ 2V2 2@ -> -2 -1 }T
1354 T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T
1355 T{ 2V3 2@ -> 5 6 }T
1356 T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T
1357 T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T
1358
1359 ; ----------------------------------------------------------------------------
1360 TESTING DMAX DMIN
1361
1362 T{  1.  2. DMAX -> 2. }T
1363 T{  1.  0. DMAX -> 1. }T
1364 T{  1. -1. DMAX -> 1. }T
1365 T{  1.  1. DMAX -> 1. }T
1366 T{  0.  1. DMAX -> 1. }T
1367 T{  0. -1. DMAX -> 0. }T
1368 T{ -1.  1. DMAX -> 1. }T
1369 T{ -1. -2. DMAX -> -1. }T
1370
1371 T{ MAX-2INT HI-2INT  DMAX -> MAX-2INT }T
1372 T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T
1373 T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T
1374 T{ MIN-2INT LO-2INT  DMAX -> LO-2INT  }T
1375
1376 T{ MAX-2INT  1. DMAX -> MAX-2INT }T
1377 T{ MAX-2INT -1. DMAX -> MAX-2INT }T
1378 T{ MIN-2INT  1. DMAX ->  1. }T
1379 T{ MIN-2INT -1. DMAX -> -1. }T
1380
1381
1382 T{  1.  2. DMIN ->  1. }T
1383 T{  1.  0. DMIN ->  0. }T
1384 T{  1. -1. DMIN -> -1. }T
1385 T{  1.  1. DMIN ->  1. }T
1386 T{  0.  1. DMIN ->  0. }T
1387 T{  0. -1. DMIN -> -1. }T
1388 T{ -1.  1. DMIN -> -1. }T
1389 T{ -1. -2. DMIN -> -2. }T
1390
1391 T{ MAX-2INT HI-2INT  DMIN -> HI-2INT  }T
1392 T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T
1393 T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T
1394 T{ MIN-2INT LO-2INT  DMIN -> MIN-2INT }T
1395
1396 T{ MAX-2INT  1. DMIN ->  1. }T
1397 T{ MAX-2INT -1. DMIN -> -1. }T
1398 T{ MIN-2INT  1. DMIN -> MIN-2INT }T
1399 T{ MIN-2INT -1. DMIN -> MIN-2INT }T
1400
1401 ; ----------------------------------------------------------------------------
1402 TESTING D>S DABS
1403
1404 T{  1234  0 D>S ->  1234 }T
1405 T{ -1234 -1 D>S -> -1234 }T
1406 T{ MAX-INTD  0 D>S -> MAX-INTD }T
1407 T{ MIN-INTD -1 D>S -> MIN-INTD }T
1408
1409 T{  1. DABS -> 1. }T
1410 T{ -1. DABS -> 1. }T
1411 T{ MAX-2INT DABS -> MAX-2INT }T
1412 T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T
1413
1414 ; ----------------------------------------------------------------------------
1415 TESTING M+ M*/
1416
1417 T{ HI-2INT   1 M+ -> HI-2INT   1. D+ }T
1418 T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T
1419 T{ MIN-2INT  1 M+ -> MIN-2INT  1. D+ }T
1420 T{ LO-2INT  -1 M+ -> LO-2INT  -1. D+ }T
1421
1422 ; To correct the result if the division is floored, only used when
1423 ; necessary i.e. negative quotient and remainder <> 0
1424
1425 : ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ;
1426
1427 T{  5.  7 11 M*/ ->  3. }T
1428 T{  5. -7 11 M*/ -> -3. ?FLOORED }T
1429 T{ -5.  7 11 M*/ -> -3. ?FLOORED }T
1430 T{ -5. -7 11 M*/ ->  3. }T
1431 T{ MAX-2INT  8 16 M*/ -> HI-2INT }T
1432 T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T
1433 T{ MIN-2INT  8 16 M*/ -> LO-2INT }T
1434 T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T
1435 T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T
1436 T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T
1437 T{ MIN-2INT LO-2INT NIP 1+ DUP 1- NEGATE M*/ -> 0 MAX-INTD 1- }T
1438 T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T
1439 T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T
1440 T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T
1441
1442 ; ----------------------------------------------------------------------------
1443 TESTING D. D.R
1444
1445 ; Create some large double numbers
1446 MAX-2INT 71 73 M*/ 2CONSTANT DBL1
1447 MIN-2INT 73 79 M*/ 2CONSTANT DBL2
1448
1449 : D>ASCII  ( D -- CADDR U )
1450    DUP >R <# DABS #S R> SIGN #>    ( -- CADDR1 U )
1451    HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R>
1452 ;
1453
1454 DBL1 D>ASCII 2CONSTANT "DBL1"
1455 DBL2 D>ASCII 2CONSTANT "DBL2"
1456
1457 : DOUBLEOUTPUT
1458    CR ." You should see lines duplicated:" CR
1459    5 SPACES "DBL1" TYPE CR
1460    5 SPACES DBL1 D. CR
1461    8 SPACES "DBL1" DUP >R TYPE CR
1462    5 SPACES DBL1 R> 3 + D.R CR
1463    5 SPACES "DBL2" TYPE CR
1464    5 SPACES DBL2 D. CR
1465    10 SPACES "DBL2" DUP >R TYPE CR
1466    5 SPACES DBL2 R> 5 + D.R CR
1467 ;
1468
1469 T{ DOUBLEOUTPUT -> }T
1470 ; ----------------------------------------------------------------------------
1471 TESTING 2ROT DU< (Double Number extension words)
1472
1473 T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T
1474 T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T
1475
1476 T{  1.  1. DU< -> FALSE }T
1477 T{  1. -1. DU< -> TRUE  }T
1478 T{ -1.  1. DU< -> FALSE }T
1479 T{ -1. -2. DU< -> FALSE }T
1480 T{ 0 1   1. DU< -> FALSE }T
1481 T{ 1.  0 1  DU< -> TRUE  }T
1482 T{ 0 -1 1 -2 DU< -> FALSE }T
1483 T{ 1 -2 0 -1 DU< -> TRUE  }T
1484
1485 T{ MAX-2INT HI-2INT  DU< -> FALSE }T
1486 T{ HI-2INT  MAX-2INT DU< -> TRUE  }T
1487 T{ MAX-2INT MIN-2INT DU< -> TRUE }T
1488 T{ MIN-2INT MAX-2INT DU< -> FALSE }T
1489 T{ MIN-2INT LO-2INT  DU< -> TRUE }T
1490
1491 ; ----------------------------------------------------------------------------
1492 TESTING 2VALUE
1493
1494 T{ 1111 2222 2VALUE 2VAL -> }T
1495 T{ 2VAL -> 1111 2222 }T
1496 T{ 3333 4444 TO 2VAL -> }T
1497 T{ 2VAL -> 3333 4444 }T
1498 T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T
1499 T{ 2VAL -> 5555 6666 }T
1500
1501 CR .( End of Double-Number word tests) CR