MSP430-FORTH/DOUBLE.f

   1 \ -*- coding: utf-8 -*-
   2 \
   3 \ to see kernel options, download FastForthSpecs.f
   4 \ FastForth kernel options: MSP430ASSEMBLER, CONDCOMP, DOUBLE_INPUT
   5 \
   6 \ TARGET SELECTION ( = the name of \INC\target.pat file without the extension)
   7 \ MSP_EXP430FR5739  MSP_EXP430FR5969    MSP_EXP430FR5994    MSP_EXP430FR6989
   8 \ MSP_EXP430FR4133  MSP_EXP430FR2433    CHIPSTICK_FR2433    MSP_EXP430FR2355
   9 \ LP_MSP430FR2476
  10 \ MY_MSP430FR5738_2
  11 \
  12 \ from scite editor : copy your target selection in (shift+F8) parameter 1:
  13 \
  14 \ OR
  15 \
  16 \ drag and drop this file onto SendSourceFileToTarget.bat
  17 \ then select your TARGET when asked.
  18 \
  19 \
  20 \ REGISTERS USAGE
  21 \ rDODOES to rEXIT must be saved before use and restored after
  22 \ scratch registers Y to S are free for use
  23 \ under interrupt, IP is free for use
  24 \
  25 \ FORTH conditionnals:  unary{ 0= 0< 0> }, binary{ = < > U< }
  26 \
  27 \ ASSEMBLER conditionnal usage with IF UNTIL WHILE  S<  S>=  U<   U>=  0=  0<>  0>=
  28 \
  29 \ ASSEMBLER conditionnal usage with ?GOTO      S<  S>=  U<   U>=  0=  0<>  0<
  30 \
  31
  32     CODE ABORT_DOUBLE
  33     SUB #4,PSP
  34     MOV TOS,2(PSP)
  35     MOV &KERNEL_ADDON,TOS
  36     BIT #BIT7,TOS
  37     0<> IF MOV #0,TOS THEN  \ if TOS <> 0 (DOUBLE input), set TOS = 0
  38     MOV TOS,0(PSP)
  39     MOV &VERSION,TOS
  40     SUB #400,TOS            \   FastForth V4.0
  41     COLON
  42     $0D EMIT                \ return to column 1 without CR
  43     ABORT" FastForth V4.0 please!"
  44     ABORT" build FastForth with DOUBLE_INPUT addon!"
  45     RST_RET                 \ if no abort remove this word
  46     ;
  47
  48     ABORT_DOUBLE
  49
  50 ; -----------------------------------------------------
  51 ; DOUBLE.f
  52 ; -----------------------------------------------------
  53     [DEFINED] {DOUBLE}
  54     [IF] {DOUBLE} [THEN]
  55
  56     [UNDEFINED] {DOUBLE} [IF]
  57     MARKER {DOUBLE}
  58
  59 ; ------------------------------------------------------------------
  60 ; first we download the set of definitions we need (from CORE_ANS)
  61 ; ------------------------------------------------------------------
  62
  63     [UNDEFINED] >R [IF]
  64 \ https://forth-standard.org/standard/core/toR
  65 \ >R    x --   R: -- x   push to return stack
  66     CODE >R
  67     PUSH TOS
  68     MOV @PSP+,TOS
  69     MOV @IP+,PC
  70     ENDCODE
  71     [THEN]
  72
  73     [UNDEFINED] R> [IF]
  74 \ https://forth-standard.org/standard/core/Rfrom
  75 \ R>    -- x    R: x --   pop from return stack ; CALL #RFROM performs DOVAR
  76     CODE R>
  77     SUB #2,PSP      \ 1
  78     MOV TOS,0(PSP)  \ 3
  79     MOV @RSP+,TOS   \ 2
  80     MOV @IP+,PC     \ 4
  81     ENDCODE
  82     [THEN]
  83
  84     [UNDEFINED] 0< [IF]
  85 \ https://forth-standard.org/standard/core/Zeroless
  86 \ 0<     n -- flag      true if TOS negative
  87     CODE 0<
  88     ADD TOS,TOS     \ 1 set carry if TOS negative
  89     SUBC TOS,TOS    \ 1 TOS=-1 if carry was clear
  90     XOR #-1,TOS     \ 1 TOS=-1 if carry was set
  91     MOV @IP+,PC     \
  92     ENDCODE
  93     [THEN]
  94
  95     [UNDEFINED] DROP [IF]
  96 \ https://forth-standard.org/standard/core/DROP
  97 \ DROP     x --          drop top of stack
  98     CODE DROP
  99     MOV @PSP+,TOS   \ 2
 100     MOV @IP+,PC     \ 4
 101     ENDCODE
 102     [THEN]
 103
 104     [UNDEFINED] DUP [IF]
 105 \ https://forth-standard.org/standard/core/DUP
 106 \ DUP      x -- x x      duplicate top of stack
 107     CODE DUP
 108 BW1 SUB #2,PSP      \ 2  push old TOS..
 109     MOV TOS,0(PSP)  \ 3  ..onto stack
 110     MOV @IP+,PC     \ 4
 111     ENDCODE
 112
 113     CODE ?DUP
 114 \ https://forth-standard.org/standard/core/qDUP
 115 \ ?DUP     x -- 0 | x x    DUP if nonzero
 116     CMP #0,TOS      \ 2  test for TOS nonzero
 117     0<> ?GOTO BW1    \ 2
 118     MOV @IP+,PC     \ 4
 119     ENDCODE
 120     [THEN]
 121
 122     [UNDEFINED] NIP [IF]
 123 \ https://forth-standard.org/standard/core/NIP
 124 \ NIP      x1 x2 -- x2         Drop the first item below the top of stack
 125     CODE NIP
 126     ADD #2,PSP
 127     MOV @IP+,PC
 128     ENDCODE
 129     [THEN]
 130
 131     [UNDEFINED] UM/MOD [IF]
 132 \ https://forth-standard.org/standard/core/UMDivMOD
 133 \ UM/MOD   udlo|udhi u1 -- r q   unsigned 32/16->r16 q16
 134     CODE UM/MOD
 135         PUSH #DROP      \
 136         MOV #MUSMOD,PC  \ execute MUSMOD then return to DROP
 137     ENDCODE
 138     [THEN]
 139
 140     KERNEL_ADDON @ 0<   ; test the switch: FLOORED/SYMETRIC DIVISION
 141     [IF]
 142         [UNDEFINED] FM/MOD [IF]
 143 \ https://forth-standard.org/standard/core/FMDivMOD
 144 \ FM/MOD   d1 n1 -- r q   floored signed div'n
 145         CODE FM/MOD
 146         MOV TOS,S           \           S=DIV
 147         MOV @PSP,T          \           T=DVDhi
 148         CMP #0,TOS          \           n2 >= 0 ?
 149         S< IF               \
 150             XOR #-1,TOS
 151             ADD #1,TOS      \ -- d1 u2
 152         THEN
 153         CMP #0,0(PSP)       \           d1hi >= 0 ?
 154         S< IF               \
 155             XOR #-1,2(PSP)  \           d1lo
 156             XOR #-1,0(PSP)  \           d1hi
 157             ADD #1,2(PSP)   \           d1lo+1
 158             ADDC #0,0(PSP)  \           d1hi+C
 159         THEN                \ -- uDVDlo uDVDhi uDIVlo
 160         PUSHM #3,IP         \           save IP,S,T
 161         LO2HI
 162             UM/MOD          \ -- uREMlo uQUOTlo
 163         HI2LO
 164         POPM #3,IP          \           restore T,S,IP
 165         CMP #0,T            \           T=DVDhi --> REM_sign
 166         S< IF
 167             XOR #-1,0(PSP)
 168             ADD #1,0(PSP)
 169         THEN
 170         XOR S,T             \           S=DIV XOR T=DVDhi = Quot_sign
 171         CMP #0,T            \ -- n3 u4  T=quot_sign
 172         S< IF
 173             XOR #-1,TOS
 174             ADD #1,TOS
 175         THEN                \ -- n3 n4  S=divisor
 176
 177         CMP #0,0(PSP)       \ remainder <> 0 ?
 178         0<> IF
 179             CMP #1,TOS      \ quotient < 1 ?
 180             S< IF
 181             ADD S,0(PSP)  \ add divisor to remainder
 182             SUB #1,TOS    \ decrement quotient
 183             THEN
 184         THEN
 185         MOV @IP+,PC
 186         ENDCODE
 187         [THEN]
 188
 189     [ELSE]
 190         [UNDEFINED] SM/REM [IF]
 191 \ https://forth-standard.org/standard/core/SMDivREM
 192 \ SM/REM   DVDlo DVDhi DIV -- r3 q4  symmetric signed div
 193         CODE SM/REM
 194         MOV TOS,S           \           S=DIV
 195         MOV @PSP,T          \           T=DVDhi
 196         CMP #0,TOS          \           n2 >= 0 ?
 197         S< IF               \
 198             XOR #-1,TOS
 199             ADD #1,TOS      \ -- d1 u2
 200         THEN
 201         CMP #0,0(PSP)       \           d1hi >= 0 ?
 202         S< IF               \
 203             XOR #-1,2(PSP)  \           d1lo
 204             XOR #-1,0(PSP)  \           d1hi
 205             ADD #1,2(PSP)   \           d1lo+1
 206             ADDC #0,0(PSP)  \           d1hi+C
 207         THEN                \ -- uDVDlo uDVDhi uDIVlo
 208         PUSHM #3,IP         \           save IP,S,T
 209         LO2HI
 210             UM/MOD          \ -- uREMlo uQUOTlo
 211         HI2LO
 212         POPM #3,IP          \           restore T,S,IP
 213         CMP #0,T            \           T=DVDhi --> REM_sign
 214         S< IF
 215             XOR #-1,0(PSP)
 216             ADD #1,0(PSP)
 217         THEN
 218         XOR S,T             \           S=DIV XOR T=DVDhi = Quot_sign
 219         CMP #0,T            \ -- n3 u4  T=quot_sign
 220         S< IF
 221             XOR #-1,TOS
 222             ADD #1,TOS
 223         THEN                \ -- n3 n4  S=divisor
 224         MOV @IP+,PC
 225         ENDCODE
 226         [THEN]
 227     [THEN]
 228
 229     [UNDEFINED] / [IF]
 230 \ https://forth-standard.org/standard/core/Div
 231 \ /      n1 n2 -- n3       signed quotient
 232     : /
 233     >R DUP 0< R>
 234     [ KERNEL_ADDON @ 0< ]
 235     [IF]    FM/MOD
 236     [ELSE]  SM/REM
 237     [THEN]
 238     NIP
 239     ;
 240     [THEN]
 241
 242     [UNDEFINED] C@ [IF]
 243 \ https://forth-standard.org/standard/core/CFetch
 244 \ C@     c-addr -- char   fetch char from memory
 245     CODE C@
 246     MOV.B @TOS,TOS
 247     MOV @IP+,PC
 248     ENDCODE
 249     [THEN]
 250
 251     [UNDEFINED] SWAP [IF]
 252 \ https://forth-standard.org/standard/core/SWAP
 253 \ SWAP     x1 x2 -- x2 x1    swap top two items
 254     CODE SWAP
 255     MOV @PSP,W      \ 2
 256     MOV TOS,0(PSP)  \ 3
 257     MOV W,TOS       \ 1
 258     MOV @IP+,PC     \ 4
 259     ENDCODE
 260     [THEN]
 261
 262     [UNDEFINED] OVER [IF]
 263 \ https://forth-standard.org/standard/core/OVER
 264 \ OVER    x1 x2 -- x1 x2 x1
 265     CODE OVER
 266     MOV TOS,-2(PSP)     \ 3 -- x1 (x2) x2
 267     MOV @PSP,TOS        \ 2 -- x1 (x2) x1
 268     SUB #2,PSP          \ 1 -- x1 x2 x1
 269     MOV @IP+,PC
 270     ENDCODE
 271     [THEN]
 272
 273     [UNDEFINED] ROT [IF]
 274 \ https://forth-standard.org/standard/core/ROT
 275 \ ROT    x1 x2 x3 -- x2 x3 x1
 276     CODE ROT
 277     MOV @PSP,W          \ 2 fetch x2
 278     MOV TOS,0(PSP)      \ 3 store x3
 279     MOV 2(PSP),TOS      \ 3 fetch x1
 280     MOV W,2(PSP)        \ 3 store x2
 281     MOV @IP+,PC
 282     ENDCODE
 283     [THEN]
 284
 285     [UNDEFINED] - [IF]
 286 \ https://forth-standard.org/standard/core/Minus
 287 \ -      n1/u1 n2/u2 -- n3/u3     n3 = n1-n2
 288     CODE -
 289     SUB @PSP+,TOS   \ 2  -- n2-n1 ( = -n3)
 290     XOR #-1,TOS     \ 1
 291     ADD #1,TOS      \ 1  -- n3 = -(n2-n1) = n1-n2
 292     MOV @IP+,PC
 293     ENDCODE
 294     [THEN]
 295
 296     [UNDEFINED] < [IF]      \ define < and >
 297 \ https://forth-standard.org/standard/core/less
 298 \ <      n1 n2 -- flag        test n1<n2, signed
 299     CODE <
 300     SUB @PSP+,TOS   \ 1 TOS=n2-n1
 301     S< ?GOTO FW1    \ 2 signed
 302     0<> IF          \ 2
 303 BW1 MOV #-1,TOS \ 1 flag Z = 0
 304     THEN
 305     MOV @IP+,PC
 306     ENDCODE
 307
 308 \ https://forth-standard.org/standard/core/more
 309 \ >     n1 n2 -- flag         test n1>n2, signed
 310     CODE >
 311     SUB @PSP+,TOS   \ 2 TOS=n2-n1
 312     S< ?GOTO BW1    \ 2 --> +5
 313 FW1 AND #0,TOS      \ 1 flag Z = 1
 314     MOV @IP+,PC
 315     ENDCODE
 316     [THEN]
 317
 318     [UNDEFINED] IF [IF] \ define IF THEN
 319 \ https://forth-standard.org/standard/core/IF
 320 \ IF       -- IFadr    initialize conditional forward branch
 321     CODE IF             \ immediate
 322     SUB #2,PSP          \
 323     MOV TOS,0(PSP)      \
 324     MOV &DP,TOS         \ -- HERE
 325     ADD #4,&DP          \           compile one word, reserve one word
 326     MOV #QFBRAN,0(TOS)  \ -- HERE   compile QFBRAN
 327     ADD #2,TOS          \ -- HERE+2=IFadr
 328     MOV @IP+,PC
 329     ENDCODE IMMEDIATE
 330
 331 \ https://forth-standard.org/standard/core/THEN
 332 \ THEN     IFadr --                resolve forward branch
 333     CODE THEN           \ immediate
 334     MOV &DP,0(TOS)      \ -- IFadr
 335     MOV @PSP+,TOS       \ --
 336     MOV @IP+,PC
 337     ENDCODE IMMEDIATE
 338     [THEN]
 339
 340     [UNDEFINED] ELSE [IF]
 341 \ https://forth-standard.org/standard/core/ELSE
 342 \ ELSE     IFadr -- ELSEadr        resolve forward IF branch, leave ELSEadr on stack
 343     CODE ELSE           \ immediate
 344     ADD #4,&DP          \ make room to compile two words
 345     MOV &DP,W           \ W=HERE+4
 346     MOV #BRAN,-4(W)
 347     MOV W,0(TOS)        \ HERE+4 ==> [IFadr]
 348     SUB #2,W            \ HERE+2
 349     MOV W,TOS           \ -- ELSEadr
 350     MOV @IP+,PC
 351     ENDCODE IMMEDIATE
 352     [THEN]
 353
 354     [UNDEFINED] TO [IF]
 355 \ https://forth-standard.org/standard/core/TO
 356     CODE TO
 357     BIS #UF9,SR
 358     MOV @IP+,PC
 359     ENDCODE
 360     [THEN]
 361
 362     [UNDEFINED] DOES> [IF]
 363 \ https://forth-standard.org/standard/core/DOES
 364 \ DOES>    --          set action for the latest CREATEd definition
 365     CODE DOES>
 366     MOV &LAST_CFA,W     \ W = CFA of CREATEd word
 367     MOV #DODOES,0(W)    \ replace CFA (CALL rDOCON) by new CFA (CALL rDODOES)
 368     MOV IP,2(W)         \ replace PFA by the address after DOES> as execution address
 369     MOV @RSP+,IP
 370     MOV @IP+,PC
 371     ENDCODE
 372     [THEN]
 373
 374     [UNDEFINED] SPACES [IF]
 375 \ https://forth-standard.org/standard/core/SPACES
 376 \ SPACES   n --            output n spaces
 377     CODE SPACES
 378     CMP #0,TOS
 379     0<> IF
 380         PUSH IP
 381         BEGIN
 382             LO2HI
 383             $20 EMIT
 384             HI2LO
 385             SUB #2,IP
 386             SUB #1,TOS
 387         0= UNTIL
 388         MOV @RSP+,IP
 389     THEN
 390     MOV @PSP+,TOS           \ --         drop n
 391     MOV @IP+,PC
 392     ENDCODE
 393     [THEN]
 394
 395     [UNDEFINED] 2@ [IF]
 396 \ https://forth-standard.org/standard/core/TwoFetch
 397 \ 2@    a-addr -- x1 x2    fetch 2 cells ; the lower address will appear on top of stack
 398     CODE 2@
 399     SUB #2,PSP
 400     MOV 2(TOS),0(PSP)
 401     MOV @TOS,TOS
 402     MOV @IP+,PC
 403     ENDCODE
 404     [THEN]
 405
 406     [UNDEFINED] 2! [IF]
 407 \ https://forth-standard.org/standard/core/TwoStore
 408 \ 2!    x1 x2 a-addr --    store 2 cells ; the top of stack is stored at the lower adr
 409     CODE 2!
 410     MOV @PSP+,0(TOS)
 411     MOV @PSP+,2(TOS)
 412     MOV @PSP+,TOS
 413     MOV @IP+,PC
 414     ENDCODE
 415     [THEN]
 416
 417     [UNDEFINED] 2DUP [IF]
 418 \ https://forth-standard.org/standard/core/TwoDUP
 419 \ 2DUP   x1 x2 -- x1 x2 x1 x2   dup top 2 cells
 420     CODE 2DUP
 421     SUB #4,PSP          \ -- x1 x x x2
 422     MOV TOS,2(PSP)      \ -- x1 x2 x x2
 423     MOV 4(PSP),0(PSP)   \ -- x1 x2 x1 x2
 424     NEXT
 425     ENDCODE
 426     [THEN]
 427
 428     [UNDEFINED] 2DROP [IF]
 429 \ https://forth-standard.org/standard/core/TwoDROP
 430 \ 2DROP  x1 x2 --          drop 2 cells
 431     CODE 2DROP
 432     ADD #2,PSP
 433     MOV @PSP+,TOS
 434     NEXT
 435     ENDCODE
 436     [THEN]
 437
 438     [UNDEFINED] 2SWAP [IF]
 439 \ https://forth-standard.org/standard/core/TwoSWAP
 440 \ 2SWAP  x1 x2 x3 x4 -- x3 x4 x1 x2
 441     CODE 2SWAP
 442     MOV @PSP,W          \ -- x1 x2 x3 x4    W=x3
 443     MOV 4(PSP),0(PSP)   \ -- x1 x2 x1 x4
 444     MOV W,4(PSP)        \ -- x3 x2 x1 x4
 445     MOV TOS,W           \ -- x3 x2 x1 x4    W=x4
 446     MOV 2(PSP),TOS      \ -- x3 x2 x1 x2    W=x4
 447     MOV W,2(PSP)        \ -- x3 x4 x1 x2
 448     NEXT
 449     ENDCODE
 450     [THEN]
 451
 452     [UNDEFINED] 2OVER [IF]
 453 \ https://forth-standard.org/standard/core/TwoOVER
 454 \ 2OVER  x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2
 455     CODE 2OVER
 456     SUB #4,PSP          \ -- x1 x2 x3 x x x4
 457     MOV TOS,2(PSP)      \ -- x1 x2 x3 x4 x x4
 458     MOV 8(PSP),0(PSP)   \ -- x1 x2 x3 x4 x1 x4
 459     MOV 6(PSP),TOS      \ -- x1 x2 x3 x4 x1 x2
 460     NEXT
 461     ENDCODE
 462     [THEN]
 463
 464     [UNDEFINED] 2>R [IF]
 465 \ https://forth-standard.org/standard/core/TwotoR
 466 \ ( x1 x2 -- ) ( R: -- x1 x2 )   Transfer cell pair x1 x2 to the return stack.
 467     CODE 2>R
 468     PUSH @PSP+
 469     PUSH TOS
 470     MOV @PSP+,TOS
 471     NEXT
 472     ENDCODE
 473     [THEN]
 474
 475     [UNDEFINED] 2R@ [IF]
 476 \ https://forth-standard.org/standard/core/TwoRFetch
 477 \ ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) Copy cell pair x1 x2 from the return stack.
 478     CODE 2R@
 479     SUB #4,PSP
 480     MOV TOS,2(PSP)
 481     MOV @RSP,TOS
 482     MOV 2(RSP),0(PSP)
 483     NEXT
 484     ENDCODE
 485     [THEN]
 486
 487     [UNDEFINED] 2R> [IF]
 488 \ https://forth-standard.org/standard/core/TwoRfrom
 489 \ ( -- x1 x2 ) ( R: x1 x2 -- )  Transfer cell pair x1 x2 from the return stack
 490     CODE 2R>
 491     SUB #4,PSP
 492     MOV TOS,2(PSP)
 493     MOV @RSP+,TOS
 494     MOV @RSP+,0(PSP)
 495     NEXT
 496     ENDCODE
 497     [THEN]
 498
 499 ; --------------------------
 500 ; end of definitions we need
 501 ; --------------------------
 502
 503 ; ===============================================
 504 ; DOUBLE word set
 505 ; ===============================================
 506
 507     [UNDEFINED] D. [IF]
 508 \ https://forth-standard.org/standard/double/Dd
 509 \ D.     dlo dhi --           display d (signed)
 510     CODE D.
 511     MOV TOS,S       \ S will be pushed as sign by DDOT
 512     MOV #D.,PC   \ U. + 10 = DDOT
 513     ENDCODE
 514     [THEN]
 515
 516     [UNDEFINED] 2ROT [IF]
 517 \ https://forth-standard.org/standard/double/TwoROT
 518 \ Rotate the top three cell pairs on the stack bringing cell pair x1 x2 to the top of the stack.
 519     CODE 2ROT
 520     MOV 8(PSP),X        \ 3
 521     MOV 6(PSP),Y        \ 3
 522     MOV 4(PSP),8(PSP)   \ 5
 523     MOV 2(PSP),6(PSP)   \ 5
 524     MOV @PSP,4(PSP)     \ 4
 525     MOV TOS,2(PSP)      \ 3
 526     MOV X,0(PSP)        \ 3
 527     MOV Y,TOS           \ 1
 528     NEXT
 529     ENDCODE
 530     [THEN]
 531
 532     [UNDEFINED] D>S [IF]
 533 \ https://forth-standard.org/standard/double/DtoS
 534 \ D>S    d -- n          double prec -> single.
 535     CODE D>S
 536     MOV @PSP+,TOS
 537     NEXT
 538     ENDCODE
 539     [THEN]
 540
 541     [UNDEFINED] D0= [IF]    \ define: D0= D0< D= D< DU<
 542
 543 \ https://forth-standard.org/standard/double/DZeroEqual
 544     CODE D0=
 545     ADD #2,PSP
 546     CMP #0,TOS
 547     MOV #0,TOS
 548     0= IF
 549         CMP #0,-2(PSP)
 550         0= IF
 551 BW1         MOV #-1,TOS
 552         THEN
 553     THEN
 554 BW2 AND #-1,TOS         \  to set N, Z flags
 555     NEXT
 556     ENDCODE
 557
 558 \ https://forth-standard.org/standard/double/DZeroless
 559     CODE D0<
 560     ADD #2,PSP
 561     CMP #0,TOS
 562     MOV #0,TOS
 563     S< ?GOTO BW1
 564     GOTO BW2
 565     ENDCODE
 566
 567 \ https://forth-standard.org/standard/double/DEqual
 568     CODE D=
 569     ADD #6,PSP              \ 2
 570     CMP TOS,-4(PSP)         \ 3 ud1H - ud2H
 571     MOV #0,TOS              \ 1
 572     0<> ?GOTO BW2           \ 2
 573     CMP -6(PSP),-2(PSP)     \ 4 ud1L - ud2L
 574     0= ?GOTO BW1            \ 2
 575     GOTO BW2
 576     ENDCODE
 577
 578 \ https://forth-standard.org/standard/double/Dless
 579 \ flag is true if and only if d1 is less than d2
 580     CODE D<
 581     ADD #6,PSP              \ 2
 582     CMP TOS,-4(PSP)         \ 3 d1H - d2H
 583     MOV #0,TOS              \ 1
 584     S< IF
 585 BW1     MOV #-1,TOS
 586     THEN
 587 BW3 0<> ?GOTO BW2           \ 2
 588     CMP -6(PSP),-2(PSP)     \ 4 d1L - d2L
 589     U>= ?GOTO BW2           \  to set N, Z flags
 590     U< ?GOTO BW1            \ 2
 591     ENDCODE
 592
 593 \ https://forth-standard.org/standard/double/DUless
 594 \ flag is true if and only if ud1 is less than ud2
 595     CODE DU<
 596     ADD #6,PSP              \ 2
 597     CMP TOS,-4(PSP)         \ 3 ud1H - ud2H
 598     MOV #0,TOS              \ 1
 599     U>= ?GOTO BW3
 600     U< ?GOTO BW1            \ 4
 601     ENDCODE
 602     [THEN]
 603
 604     [UNDEFINED] D+ [IF] \ define: D+ M+
 605 \ https://forth-standard.org/standard/double/DPlus
 606     CODE D+
 607 BW1 ADD @PSP+,2(PSP)
 608     ADDC @PSP+,TOS
 609     MOV @IP+,PC         \ 4
 610     ENDCODE
 611
 612 \ https://forth-standard.org/standard/double/MPlus
 613     CODE M+
 614     SUB #2,PSP
 615     CMP #0,TOS
 616     MOV TOS,0(PSP)
 617     MOV #-1,TOS
 618     0>= IF
 619         MOV #0,TOS
 620     THEN
 621     GOTO BW1
 622     ENDCODE
 623     [THEN]
 624
 625     [UNDEFINED] D- [IF]
 626 \ https://forth-standard.org/standard/double/DMinus
 627     CODE D-
 628     SUB @PSP+,2(PSP)
 629     SUBC TOS,0(PSP)
 630     MOV @PSP+,TOS
 631     MOV @IP+,PC         \ 4
 632     ENDCODE
 633     [THEN]
 634
 635     [UNDEFINED] DNEGATE [IF]    \ define DNEGATE DABS
 636 \ https://forth-standard.org/standard/double/DNEGATE
 637     CODE DNEGATE
 638 BW1 XOR #-1,0(PSP)
 639     XOR #-1,TOS
 640     ADD #1,0(PSP)
 641     ADDC #0,TOS
 642     MOV @IP+,PC         \ 4
 643     ENDCODE
 644
 645 \ https://forth-standard.org/standard/double/DABS
 646 \ DABS     d1 -- |d1|     absolute value
 647     CODE DABS
 648     CMP #0,TOS       \  1
 649     0< ?GOTO BW1
 650     MOV @IP+,PC
 651     ENDCODE
 652     [THEN]
 653
 654     [UNDEFINED] D2/ [IF]
 655 \ https://forth-standard.org/standard/double/DTwoDiv
 656     CODE D2/
 657     RRA TOS
 658     RRC 0(PSP)
 659     MOV @IP+,PC         \ 4
 660     ENDCODE
 661     [THEN]
 662
 663     [UNDEFINED] D2* [IF]
 664 \ https://forth-standard.org/standard/double/DTwoTimes
 665     CODE D2*
 666     ADD @PSP,0(PSP)
 667     ADDC TOS,TOS
 668     MOV @IP+,PC         \ 4
 669     ENDCODE
 670     [THEN]
 671
 672     [UNDEFINED] DMAX [IF]
 673 \ https://forth-standard.org/standard/double/DMAX
 674     : DMAX              \ -- d1 d2
 675     2OVER 2OVER         \ -- d1 d2 d1 d2
 676     D< IF               \ -- d1 d2
 677         2>R 2DROP 2R>   \ -- d2
 678     ELSE                \ -- d1 d2
 679         2DROP           \ -- d1
 680     THEN
 681     ;
 682     [THEN]
 683
 684     [UNDEFINED] DMIN [IF]
 685 \ https://forth-standard.org/standard/double/DMIN
 686     : DMIN              \ -- d1 d2
 687     2OVER 2OVER         \ -- d1 d2 d1 d2
 688     D< IF               \ -- d1 d2
 689         2DROP           \ -- d1
 690     ELSE
 691         2>R 2DROP 2R>   \ -- d1 d2
 692     THEN                \ -- d2
 693     ;
 694     [THEN]
 695
 696     [UNDEFINED] M*/ [IF]
 697 \ https://forth-standard.org/standard/double/MTimesDiv
 698
 699         RST_SET
 700
 701         CODE TSTBIT     \ addr bit_mask -- true/flase flag
 702         MOV @PSP+,X
 703         AND @X,TOS
 704         MOV @IP+,PC
 705         ENDCODE
 706
 707         KERNEL_ADDON HMPY TSTBIT \ hardware MPY ?
 708
 709         RST_RET     \ remove TSTBIT definition
 710
 711         [IF]   ; MSP430FRxxxx with hardware_MPY
 712
 713         CODE M*/                \ d1 * n1 / +n2 -- d2
 714         MOV 4(PSP),&MPYS32L     \ 5             Load 1st operand    d1lo
 715         MOV 2(PSP),&MPYS32H     \ 5                                 d1hi
 716         MOV @PSP+,&OP2          \ 4 -- d1 n2    load 2nd operand    n1
 717         MOV TOS,T               \ T = DIV
 718         NOP3
 719         MOV &RES0,S             \ 3 S = RESlo
 720         MOV &RES1,TOS           \ 3 TOS = RESmi
 721         MOV &RES2,W             \ 3 W = REShi
 722         MOV #0,rDOCON           \ clear sign flag
 723         CMP #0,W                \ negative product ?
 724         S< IF                   \ compute ABS value if yes
 725             XOR #-1,S
 726             XOR #-1,TOS
 727             XOR #-1,W
 728             ADD #1,S
 729             ADDC #0,TOS
 730             ADDC #0,W
 731             MOV #-1,rDOCON       \ set sign flag
 732         THEN
 733
 734         [ELSE]  ; no hardware multiplier
 735
 736         CODE M*/    \ d1lo d1hi n1 +n2 -- d2lo d2hi
 737         MOV #0,rDOCON               \ rDOCON = sign
 738         CMP #0,2(PSP)               \ d1 < 0 ?
 739         S< IF
 740             XOR #-1,4(PSP)
 741             XOR #-1,2(PSP)
 742             ADD #1,4(PSP)
 743             ADDC #0,2(PSP)
 744             MOV #-1,rDOCON
 745         THEN                        \ ud1
 746         CMP #0,0(PSP)               \ n1 < 0 ?
 747         S< IF
 748             XOR #-1,0(PSP)
 749             ADD #1,0(PSP)           \ u1
 750             XOR #-1,rDOCON
 751         THEN                        \ let's process UM*     -- ud1lo ud1hi u1 +n2
 752                     MOV 4(PSP),Y            \ 3 uMDlo
 753                     MOV 2(PSP),T            \ 3 uMDhi
 754                     MOV @PSP+,S             \ 2 uMRlo        -- ud1lo ud1hi +n2
 755                     MOV #0,rDODOES          \ 1 uMDlo=0
 756                     MOV #0,2(PSP)           \ 3 uRESlo=0
 757                     MOV #0,0(PSP)           \ 3 uRESmi=0     -- uRESlo uRESmi +n2
 758                     MOV #0,W                \ 1 uREShi=0
 759                     MOV #1,X                \ 1 BIT TEST REGlo
 760         BEGIN       BIT X,S                 \ 1 test actual bit in uMRlo
 761             0<> IF  ADD Y,2(PSP)            \ 3 IF 1: ADD uMDlo TO uRESlo
 762                     ADDC T,0(PSP)           \ 3      ADDC uMDmi TO uRESmi
 763                     ADDC rDODOES,W          \ 1      ADDC uMRlo TO uREShi
 764             THEN    ADD Y,Y                 \ 1 (RLA LSBs) uMDlo *2
 765                     ADDC T,T                \ 1 (RLC MSBs) uMDhi *2
 766                     ADDC rDODOES,rDODOES    \ 1 (RLA LSBs) uMDlo *2
 767                     ADD X,X                 \ 1 (RLA) NEXT BIT TO TEST
 768         U>= UNTIL                           \ 1 IF BIT IN CARRY: FINISHED   W=uREShi
 769 \       TOS     +n2
 770 \       W       REShi
 771 \       0(PSP)  RESmi
 772 \       2(PSP)  RESlo
 773         MOV TOS,T
 774         MOV @PSP,TOS
 775         MOV 2(PSP),S
 776
 777         [THEN]  ; endcase of software/hardware_MPY
 778
 779 \   process division
 780 \   reg     input           output
 781 \   ------------------------------
 782 \   S       = DVD(15-0)
 783 \   TOS     = DVD(31-16)
 784 \   W       = DVD(47-32)    REM
 785 \   T       = DIV(15-0)
 786 \   X       = Don't care    QUOTlo
 787 \   Y       = Don't care    QUOThi
 788 \   rDODOES = count
 789 \   rDOCON  = sign
 790 \   2(PSP)                  REM
 791 \   0(PSP)                  QUOTlo
 792 \   TOS                     QUOThi
 793     MOV #32,rDODOES         \ 2  init loop count
 794     CMP #0,W                \ DVDhi = 0 ?
 795     0= IF                   \ if yes
 796         MOV TOS,W           \ DVDmi --> DVDhi
 797         CALL #MDIV1DIV2     \ with loop count / 2
 798     ELSE
 799         CALL #MDIV1         \ -- urem ud2lo ud2hi
 800     THEN
 801     MOV @PSP+,0(PSP)        \ -- d2lo d2hi
 802     CMP #0,rDOCON           \ RES sign is set ?
 803     0<> IF                  \ DNEGATE quot
 804         XOR #-1,0(PSP)
 805         XOR #-1,TOS
 806         ADD #1,0(PSP)
 807         ADDC #0,TOS
 808         CMP #0,&KERNEL_ADDON    \ floored/symetric division flag test
 809         S< IF                   \ if floored division and quot<0
 810             CMP #0,W            \ remainder <> 0 ?
 811             0<> IF              \ if floored division, quot<0 and remainder <>0
 812                 SUB #1,0(PSP)   \ decrement quotient
 813                 SUBC #0,TOS
 814             THEN
 815         THEN
 816     THEN
 817     MOV #XDODOES,rDODOES
 818     MOV #XDOCON,rDOCON
 819     MOV @IP+,PC             \ 52 words
 820     ENDCODE
 821     [THEN]
 822
 823     [UNDEFINED] 2VARIABLE [IF]
 824 \ https://forth-standard.org/standard/double/TwoVARIABLE
 825     : 2VARIABLE \  --
 826     CREATE
 827     HI2LO
 828     ADD #4,&DP
 829     MOV @RSP+,IP
 830     MOV @IP+,PC
 831     ENDCODE
 832     [THEN]
 833
 834     [UNDEFINED] 2CONSTANT [IF]
 835 \ https://forth-standard.org/standard/double/TwoCONSTANT
 836     : 2CONSTANT \  udlo/dlo/Flo udhi/dhi/Shi --         to create double or s15q16 CONSTANT
 837     CREATE
 838     , ,             \ compile hi then lo
 839     DOES>
 840     2@              \ execution part
 841     ;
 842     [THEN]
 843
 844     [UNDEFINED] 2VALUE [IF]
 845 \ https://forth-standard.org/standard/double/TwoVALUE
 846     : 2VALUE        \ x1 x2 "<spaces>name" --
 847     CREATE , ,      \ compile Shi then Flo
 848     DOES>
 849     HI2LO
 850     MOV @RSP+,IP
 851     BIT #UF9,SR     \ flag set by TO
 852     0= IF
 853         MOV #2@,PC  \ execute TwoFetch
 854     THEN
 855     BIC #UF9,SR     \ clear flag
 856     MOV #2!,PC      \ execute TwoStore
 857     ENDCODE
 858     [THEN]
 859
 860
 861     [UNDEFINED] 2LITERAL [IF]
 862 \ https://forth-standard.org/standard/double/TwoLITERAL
 863     CODE 2LITERAL
 864     BIS #UF9,SR     \ see LITERAL
 865     MOV #LITERAL,PC
 866     ENDCODE IMMEDIATE
 867     [THEN]
 868
 869
 870     [UNDEFINED] D.R [IF]
 871 \ https://forth-standard.org/standard/double/DDotR
 872 \ D.R       d n --
 873     : D.R
 874     >R SWAP OVER DABS <# #S ROT SIGN #>
 875     R> OVER - SPACES TYPE
 876     ;
 877     [THEN]
 878
 879     RST_SET
 880
 881     [THEN] \ endof [UNDEFINED] {DOUBLE}
 882
 883 ; -------------------------------
 884 ; Complement to pass DOUBLE TESTS
 885 ; -------------------------------
 886
 887     [UNDEFINED] SWAP [IF]
 888 \ https://forth-standard.org/standard/core/SWAP
 889 \ SWAP     x1 x2 -- x2 x1    swap top two items
 890     CODE SWAP
 891     MOV @PSP,W      \ 2
 892     MOV TOS,0(PSP)  \ 3
 893     MOV W,TOS       \ 1
 894     MOV @IP+,PC     \ 4
 895     ENDCODE
 896     [THEN]
 897
 898     [UNDEFINED] VARIABLE [IF]
 899 \ https://forth-standard.org/standard/core/VARIABLE
 900 \ VARIABLE <name>       --     define a Forth VARIABLE
 901     : VARIABLE
 902     CREATE
 903     HI2LO
 904     MOV #DOVAR,-4(W)    \   CFA = CALL rDOVAR
 905     MOV @RSP+,IP
 906     MOV @IP+,PC
 907     ENDCODE
 908     [THEN]
 909
 910     [UNDEFINED] CONSTANT [IF]
 911 \ https://forth-standard.org/standard/core/CONSTANT
 912 \ CONSTANT <name>     n --    define a Forth CONSTANT
 913     : CONSTANT
 914     CREATE
 915     HI2LO
 916     MOV TOS,-2(W)       \   PFA = n
 917     MOV @PSP+,TOS
 918     MOV @RSP+,IP
 919     MOV @IP+,PC
 920     ENDCODE
 921     [THEN]
 922
 923     [UNDEFINED] CELLS [IF]
 924 \ https://forth-standard.org/standard/core/CELLS
 925 \ CELLS    n1 -- n2            cells->adrs units
 926     CODE CELLS
 927     ADD TOS,TOS
 928     MOV @IP+,PC
 929     ENDCODE
 930     [THEN]
 931
 932     [UNDEFINED] DEPTH [IF]
 933 \ https://forth-standard.org/standard/core/DEPTH
 934 \ DEPTH    -- +n        number of items on stack, must leave 0 if stack empty
 935     CODE DEPTH
 936     MOV TOS,-2(PSP)
 937     MOV #PSTACK,TOS
 938     SUB PSP,TOS     \ PSP-S0--> TOS
 939     RRA TOS         \ TOS/2   --> TOS
 940     SUB #2,PSP      \ post decrement stack...
 941     MOV @IP+,PC
 942     ENDCODE
 943     [THEN]
 944
 945     [UNDEFINED] IF [IF]     \ define IF THEN
 946 \ https://forth-standard.org/standard/core/IF
 947 \ IF       -- IFadr    initialize conditional forward branch
 948     CODE IF       \ immediate
 949     SUB #2,PSP              \
 950     MOV TOS,0(PSP)          \
 951     MOV &DP,TOS             \ -- HERE
 952     ADD #4,&DP              \           compile one word, reserve one word
 953     MOV #QFBRAN,0(TOS)      \ -- HERE   compile QFBRAN
 954     ADD #2,TOS              \ -- HERE+2=IFadr
 955     MOV @IP+,PC
 956     ENDCODE IMMEDIATE
 957
 958 \ https://forth-standard.org/standard/core/THEN
 959 \ THEN     IFadr --                resolve forward branch
 960     CODE THEN               \ immediate
 961     MOV &DP,0(TOS)          \ -- IFadr
 962     MOV @PSP+,TOS           \ --
 963     MOV @IP+,PC
 964     ENDCODE IMMEDIATE
 965     [THEN]
 966
 967     [UNDEFINED] ELSE [IF]
 968 \ https://forth-standard.org/standard/core/ELSE
 969 \ ELSE     IFadr -- ELSEadr        resolve forward IF branch, leave ELSEadr on stack
 970     CODE ELSE     \ immediate
 971     ADD #4,&DP              \ make room to compile two words
 972     MOV &DP,W               \ W=HERE+4
 973     MOV #BRAN,-4(W)
 974     MOV W,0(TOS)            \ HERE+4 ==> [IFadr]
 975     SUB #2,W                \ HERE+2
 976     MOV W,TOS               \ -- ELSEadr
 977     MOV @IP+,PC
 978     ENDCODE IMMEDIATE
 979     [THEN]
 980
 981     [UNDEFINED] DO [IF] \ define DO LOOP +LOOP
 982
 983 \ https://forth-standard.org/standard/core/DO
 984 \ DO       -- DOadr   L: -- 0
 985     HDNCODE XDO         \ DO run time
 986     MOV #$8000,X        \ 2 compute 8000h-limit = "fudge factor"
 987     SUB @PSP+,X         \ 2
 988     MOV TOS,Y           \ 1 loop ctr = index+fudge
 989     ADD X,Y             \ 1 Y = INDEX
 990     PUSHM #2,X          \ 4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX
 991     MOV @PSP+,TOS       \ 2
 992     MOV @IP+,PC         \ 4
 993     ENDCODE
 994
 995     CODE DO
 996     SUB #2,PSP          \
 997     MOV TOS,0(PSP)      \
 998     ADD #2,&DP          \   make room to compile xdo
 999     MOV &DP,TOS         \ -- HERE+2
1000     MOV #XDO,-2(TOS)    \   compile xdo
1001     ADD #2,&LEAVEPTR    \ -- HERE+2     LEAVEPTR+2
1002     MOV &LEAVEPTR,W     \
1003     MOV #0,0(W)         \ -- HERE+2     L-- 0, init
1004     MOV @IP+,PC
1005     ENDCODE IMMEDIATE
1006
1007 \ https://forth-standard.org/standard/core/LOOP
1008 \ LOOP    DOadr --         L-- an an-1 .. a1 0
1009     HDNCODE XLOOP       \   LOOP run time
1010     ADD #1,0(RSP)       \ 4 increment INDEX
1011 BW1 BIT #$100,SR        \ 2 is overflow bit set?
1012     0= IF               \   branch if no overflow
1013         MOV @IP,IP
1014         MOV @IP+,PC
1015     THEN
1016     ADD #4,RSP          \ 1 empties RSP
1017     ADD #2,IP           \ 1 overflow = loop done, skip branch ofs
1018     MOV @IP+,PC         \ 4 14~ taken or not taken xloop/loop
1019     ENDCODE             \
1020
1021     CODE LOOP
1022     MOV #XLOOP,X
1023 BW2 ADD #4,&DP          \ make room to compile two words
1024     MOV &DP,W
1025     MOV X,-4(W)         \ xloop --> HERE
1026     MOV TOS,-2(W)       \ DOadr --> HERE+2
1027     BEGIN                   \ resolve all "leave" adr
1028         MOV &LEAVEPTR,TOS   \ -- Adr of top LeaveStack cell
1029         SUB #2,&LEAVEPTR    \ --
1030         MOV @TOS,TOS        \ -- first LeaveStack value
1031         CMP #0,TOS          \ -- = value left by DO ?
1032     0<> WHILE
1033         MOV W,0(TOS)        \ move adr after loop as UNLOOP adr
1034     REPEAT
1035     MOV @PSP+,TOS
1036     MOV @IP+,PC
1037     ENDCODE IMMEDIATE
1038
1039 \ https://forth-standard.org/standard/core/PlusLOOP
1040 \ +LOOP   adrs --   L-- an an-1 .. a1 0
1041     HDNCODE XPLOO   \   +LOOP run time
1042     ADD TOS,0(RSP)  \ 4 increment INDEX by TOS value
1043     MOV @PSP+,TOS   \ 2 get new TOS, doesn't change flags
1044     GOTO BW1        \ 2
1045     ENDCODE         \
1046
1047     CODE +LOOP
1048     MOV #XPLOO,X
1049     GOTO BW2
1050     ENDCODE IMMEDIATE
1051     [THEN]
1052
1053     [UNDEFINED] I [IF]
1054 \ https://forth-standard.org/standard/core/I
1055 \ I        -- n   R: sys1 sys2 -- sys1 sys2
1056 \                  get the innermost loop index
1057     CODE I
1058     SUB #2,PSP              \ 1 make room in TOS
1059     MOV TOS,0(PSP)          \ 3
1060     MOV @RSP,TOS            \ 2 index = loopctr - fudge
1061     SUB 2(RSP),TOS          \ 3
1062     MOV @IP+,PC             \ 4 13~
1063     ENDCODE
1064     [THEN]
1065
1066     [UNDEFINED] + [IF]
1067 \ https://forth-standard.org/standard/core/Plus
1068 \ +       n1/u1 n2/u2 -- n3/u3     add n1+n2
1069     CODE +
1070     ADD @PSP+,TOS
1071     MOV @IP+,PC
1072     ENDCODE
1073     [THEN]
1074
1075     [UNDEFINED] = [IF]
1076 \ https://forth-standard.org/standard/core/Equal
1077 \ =      x1 x2 -- flag         test x1=x2
1078     CODE =
1079     SUB @PSP+,TOS   \ 2
1080     0<> IF          \ 2
1081         AND #0,TOS  \ 1
1082         MOV @IP+,PC \ 4
1083     THEN
1084     XOR #-1,TOS     \ 1 flag Z = 1
1085     MOV @IP+,PC     \ 4
1086     ENDCODE
1087     [THEN]
1088
1089     [UNDEFINED] 0= [IF]
1090 \ https://forth-standard.org/standard/core/ZeroEqual
1091 \ 0=     n/u -- flag    return true if TOS=0
1092     CODE 0=
1093     SUB #1,TOS      \ borrow (clear cy) if TOS was 0
1094     SUBC TOS,TOS    \ TOS=-1 if borrow was set
1095     MOV @IP+,PC
1096     ENDCODE
1097     [THEN]
1098
1099     [UNDEFINED] SOURCE [IF]
1100 \ https://forth-standard.org/standard/core/SOURCE
1101 \ SOURCE    -- adr u    of current input buffer
1102     CODE SOURCE
1103     SUB #4,PSP
1104     MOV TOS,2(PSP)
1105     MOV &SOURCE_LEN,TOS
1106     MOV &SOURCE_ORG,0(PSP)
1107     MOV @IP+,PC
1108     ENDCODE
1109     [THEN]
1110
1111     [UNDEFINED] >IN [IF]
1112 \ https://forth-standard.org/standard/core/toIN
1113 \ C >IN     -- a-addr       holds offset in input stream
1114     TOIN CONSTANT >IN
1115     [THEN]
1116
1117     [UNDEFINED] 1+ [IF]
1118 \ https://forth-standard.org/standard/core/OnePlus
1119 \ 1+      n1/u1 -- n2/u2       add 1 to TOS
1120     CODE 1+
1121     ADD #1,TOS
1122     MOV @IP+,PC
1123     ENDCODE
1124     [THEN]
1125
1126     [UNDEFINED] CHAR [IF]
1127 \ https://forth-standard.org/standard/core/CHAR
1128 \ CHAR   -- char           parse ASCII character
1129     : CHAR
1130         $20 WORD 1+ C@
1131     ;
1132     [THEN]
1133
1134     [UNDEFINED] [CHAR] [IF]
1135 \ https://forth-standard.org/standard/core/BracketCHAR
1136 \ [CHAR]   --          compile character literal
1137     : [CHAR]
1138         CHAR POSTPONE LITERAL
1139     ; IMMEDIATE
1140     [THEN]
1141
1142     [UNDEFINED] 2/ [IF]
1143 \ https://forth-standard.org/standard/core/TwoDiv
1144 \ 2/      x1 -- x2        arithmetic right shift
1145     CODE 2/
1146     RRA TOS
1147     MOV @IP+,PC
1148     ENDCODE
1149     [THEN]
1150
1151     [UNDEFINED] INVERT [IF]
1152 \ https://forth-standard.org/standard/core/INVERT
1153 \ INVERT   x1 -- x2            bitwise inversion
1154     CODE INVERT
1155     XOR #-1,TOS
1156     MOV @IP+,PC
1157     ENDCODE
1158     [THEN]
1159
1160     [UNDEFINED] RSHIFT [IF]
1161 \ https://forth-standard.org/standard/core/RSHIFT
1162 \ RSHIFT  x1 u -- x2    logical R7 shift u places
1163     CODE RSHIFT
1164     MOV @PSP+,W
1165     AND #$1F,TOS       \ no need to shift more than 16
1166     0<> IF
1167         BEGIN
1168             BIC #C,SR   \ Clr Carry
1169             RRC W
1170             SUB #1,TOS
1171         0= UNTIL
1172     THEN
1173     MOV W,TOS
1174     MOV @IP+,PC
1175     ENDCODE
1176     [THEN]
1177
1178     [UNDEFINED] S>D [IF]
1179 \ https://forth-standard.org/standard/core/StoD
1180 \ S>D    n -- d          single -> double prec.
1181     : S>D
1182         DUP 0<
1183     ;
1184     [THEN]
1185
1186     [UNDEFINED] 1- [IF]
1187 \ https://forth-standard.org/standard/core/OneMinus
1188 \ 1-      n1/u1 -- n2/u2     subtract 1 from TOS
1189     CODE 1-
1190     SUB #1,TOS
1191     MOV @IP+,PC
1192     ENDCODE
1193     [THEN]
1194
1195     [UNDEFINED] NEGATE [IF]
1196 \ https://forth-standard.org/standard/core/NEGATE
1197 \ C NEGATE   x1 -- x2            two's complement
1198     CODE NEGATE
1199     XOR #-1,TOS
1200     ADD #1,TOS
1201     MOV @IP+,PC
1202     ENDCODE
1203     [THEN]
1204
1205     [UNDEFINED] HERE [IF]
1206     CODE HERE
1207     MOV #BEGIN,PC
1208     ENDCODE
1209     [THEN]
1210
1211     [UNDEFINED] CHARS [IF]
1212 \ https://forth-standard.org/standard/core/CHARS
1213 \ CHARS    n1 -- n2            chars->adrs units
1214     CODE CHARS
1215     MOV @IP+,PC
1216     ENDCODE
1217     [THEN]
1218
1219     [UNDEFINED] MOVE [IF]
1220 \ https://forth-standard.org/standard/core/MOVE
1221 \ MOVE    addr1 addr2 u --     smart move
1222 \             VERSION FOR 1 ADDRESS UNIT = 1 CHAR
1223     CODE MOVE
1224     MOV TOS,W           \ W = cnt
1225     MOV @PSP+,Y         \ Y = addr2 = dst
1226     MOV @PSP+,X         \ X = addr1 = src
1227     MOV @PSP+,TOS       \ pop new TOS
1228     CMP #0,W            \ count = 0 ?
1229     0<> IF              \ if 0, already done !
1230         CMP X,Y         \ Y-X \ dst - src
1231         0<> IF          \ else already done !
1232             U< IF       \ U< if src > dst
1233                 BEGIN   \ copy W bytes
1234                     MOV.B @X+,0(Y)
1235                     ADD #1,Y
1236                     SUB #1,W
1237                 0= UNTIL
1238                 MOV @IP+,PC \ out 1 of MOVE ====>
1239             THEN        \ U>= if dst > src
1240             ADD W,Y     \ copy W bytes beginning with the end
1241             ADD W,X
1242             BEGIN
1243                 SUB #1,X
1244                 SUB #1,Y
1245                 MOV.B @X,0(Y)
1246                 SUB #1,W
1247             0= UNTIL
1248         THEN
1249     THEN
1250     MOV @IP+,PC \ out 2 of MOVE ====>
1251     ENDCODE
1252     [THEN]
1253
1254     [UNDEFINED] DECIMAL [IF]
1255 \ https://forth-standard.org/standard/core/DECIMAL
1256     CODE DECIMAL
1257     MOV #$0A,&BASEADR
1258     MOV @IP+,PC
1259     ENDCODE
1260     [THEN]
1261
1262     [UNDEFINED] BASE [IF]
1263 \ https://forth-standard.org/standard/core/BASE
1264 \ BASE    -- a-addr       holds conversion radix
1265     BASEADR CONSTANT BASE
1266     [THEN]
1267
1268     [UNDEFINED] ( [IF]
1269 \ https://forth-standard.org/standard/core/p
1270 \ (         --          skip input until char ) or EOL
1271     : (
1272     ')' WORD DROP
1273     ; IMMEDIATE
1274     [THEN]
1275
1276     [UNDEFINED] .( [IF] ; "
1277 \ https://forth-standard.org/standard/core/Dotp
1278 \ .(        --          type comment immediatly.
1279     CODE .(        ; "
1280     MOV #0,&CAPS    \ CAPS OFF
1281     COLON
1282     ')' WORD
1283     COUNT TYPE
1284     $20 CAPS !      \ CAPS ON
1285     ; IMMEDIATE
1286     [THEN]
1287
1288     [UNDEFINED] CR [IF]
1289 \ https://forth-standard.org/standard/core/CR
1290 \ CR      --               send CR+LF to the output device
1291 \    DEFER CR       \ DEFERed definition, by default executes :NONAME part
1292     CODE CR         \ replaced by this CODE definition
1293     MOV #NEXT_ADR,PC
1294     ENDCODE
1295
1296     :NONAME
1297     'CR' EMIT 'LF' EMIT
1298     ; IS CR
1299     [THEN]
1300
1301 \ ==============================================================================
1302 \ TESTER
1303 \ ==============================================================================
1304 \
1305 \ From: John Hayes S1I
1306 \ Subject: tester.fr
1307 \ Date: Mon, 27 Nov 95 13:10:09 PST
1308 \
1309 \ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
1310 \ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
1311 \ VERSION 1.1
1312 \
1313 \ 22/1/09 The words { and } have been changed to T{ and }T respectively to
1314 \ agree with the Forth 200X file ttester.fs. This avoids clashes with
1315 \ locals using { ... } and the FSL use of }
1316 \
1317
1318 \ 13/05/14 jmt. added colorised error messages.
1319  0 CONSTANT FALSE
1320 -1 CONSTANT TRUE
1321
1322 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
1323 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
1324 VARIABLE VERBOSE
1325     FALSE VERBOSE !
1326 \   TRUE VERBOSE !
1327 \
1328 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1329 \     DEPTH ?DUP
1330 \             IF DUP 0< IF NEGATE 0
1331 \             DO 0 LOOP
1332 \             ELSE 0 DO DROP LOOP THEN
1333 \             THEN ;
1334 \
1335 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1336 \         \ THE LINE THAT HAD THE ERROR.
1337 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
1338 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
1339 \     QUIT  \ *** Uncomment this line to QUIT on an error
1340 \ ;
1341
1342 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
1343 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
1344
1345 : T{        \ ( -- ) SYNTACTIC SUGAR.
1346     ;
1347
1348 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
1349     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
1350     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
1351         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1352     THEN ;
1353
1354 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
1355             \ (ACTUAL) CONTENTS.
1356     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
1357         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
1358         0 DO                    \ FOR EACH STACK ITEM
1359             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
1360 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN \ jmt
1361             = 0= IF TRUE ABORT" INCORRECT RESULT" THEN      \ jmt : abort with colorised message
1362         LOOP
1363         THEN
1364     ELSE                 \ DEPTH MISMATCH
1365 \       S" WRONG NUMBER OF RESULTS: " ERROR     \ jmt
1366         TRUE ABORT" WRONG NUMBER OF RESULTS"    \ jmt : abort with colorised message
1367     THEN ;
1368
1369 : TESTING   \ ( -- ) TALKING COMMENT.
1370     SOURCE VERBOSE @
1371     IF DUP >R TYPE CR R> >IN !
1372     ELSE >IN ! DROP [CHAR] * EMIT
1373     THEN ;
1374
1375 \ Constant definitions
1376
1377 DECIMAL
1378
1379 0 INVERT        CONSTANT 1SD
1380 1SD 1 RSHIFT    CONSTANT MAX-INTD   \ 01...1
1381 MAX-INTD INVERT CONSTANT MIN-INTD   \ 10...0
1382 MAX-INTD 2/     CONSTANT HI-INT     \ 001...1
1383 MIN-INTD 2/     CONSTANT LO-INT     \ 110...1
1384
1385 \ 1SD .
1386 \ MAX-INTD .
1387 \ MIN-INTD .
1388 \ HI-INT .
1389 \ LO-INT .
1390
1391 ECHO
1392
1393 \ ==============================================================================
1394 \ DOUBLE TEST
1395 \ ==============================================================================
1396 \ https://raw.githubusercontent.com/gerryjackson/forth2012-test-suite/master/src/doubletest.fth
1397 \
1398 \ To test the ANS Forth Double-Number word set and double number extensions
1399 \
1400 \ This program was written by Gerry Jackson in 2006, with contributions from
1401 \ others where indicated, and is in the public domain - it can be distributed
1402 \ and/or modified in any way but please retain this notice.
1403 \
1404 \ This program is distributed in the hope that it will be useful,
1405 \ but WITHOUT ANY WARRANTY; without even the implied warranty of
1406 \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
1407 \
1408 \ The tests are not claimed to be comprehensive or correct
1409 \ ------------------------------------------------------------------------------
1410 \ Version 0.13  Assumptions and dependencies changed
1411 \         0.12  1 August 2015 test D< acts on MS cells of double word
1412 \         0.11  7 April 2015 2VALUE tested
1413 \         0.6   1 April 2012 Tests placed in the public domain.
1414 \               Immediate 2CONSTANTs and 2VARIABLEs tested
1415 \         0.5   20 November 2009 Various constants renamed to avoid
1416 \               redefinition warnings. <TRUE> and <FALSE> replaced
1417 \               with TRUE and FALSE
1418 \         0.4   6 March 2009 { and } replaced with T{ and }T
1419 \               Tests rewritten to be independent of word size and
1420 \               tests re-ordered
1421 \         0.3   20 April 2007 ANS Forth words changed to upper case
1422 \         0.2   30 Oct 2006 Updated following GForth test to include
1423 \               various constants from core.fr
1424 \         0.1   Oct 2006 First version released
1425 \ ------------------------------------------------------------------------------
1426 \ The tests are based on John Hayes test program for the core word set
1427 \
1428 \ Words tested in this file are:
1429 \     2CONSTANT 2LITERAL 2VARIABLE D+ D- D. D.R D0< D0= D2* D2/
1430 \     D< D= D>S DABS DMAX DMIN DNEGATE M*/ M+ 2ROT DU<
1431 \ Also tests the interpreter and compiler reading a double number
1432 \ ------------------------------------------------------------------------------
1433 \ Assumptions and dependencies:
1434 \     - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been
1435 \       included prior to this file
1436 \     - the Core word set is available and tested
1437 ; ----------------------------------------------------------------------------
1438 TESTING interpreter and compiler reading double numbers, with/without prefixes
1439
1440 T{ 1. -> 1 0 }T
1441 T{ -2. -> -2 -1 }T
1442 T{ : RDL1 3. ; RDL1 -> 3 0 }T
1443 T{ : RDL2 -4. ; RDL2 -> -4 -1 }T
1444
1445 VARIABLE OLD-DBASE
1446 DECIMAL BASE @ OLD-DBASE !
1447 T{ #12346789. -> 12346789. }T
1448 T{ #-12346789. -> -12346789. }T
1449 T{ $12aBcDeF. -> 313249263. }T
1450 T{ $-12AbCdEf. -> -313249263. }T
1451 T{ %10010110. -> 150. }T
1452 T{ %-10010110. -> -150. }T
1453 ; Check BASE is unchanged
1454 T{ BASE @ OLD-DBASE @ = -> TRUE }T
1455
1456 ; Repeat in Hex mode
1457 16 OLD-DBASE ! 16 BASE !
1458 T{ #12346789. -> BC65A5. }T
1459 T{ #-12346789. -> -BC65A5. }T
1460 T{ $12aBcDeF. -> 12AbCdeF. }T
1461 T{ $-12AbCdEf. -> -12ABCDef. }T
1462 T{ %10010110. -> 96. }T
1463 T{ %-10010110. -> -96. }T
1464 ; Check BASE is unchanged
1465 T{ BASE @ OLD-DBASE @ = -> TRUE }T   \ 2
1466
1467 DECIMAL
1468 ; Check number prefixes in compile mode
1469 T{ : dnmp  #8327. $-2cbe. %011010111. ; dnmp -> 8327. -11454. 215. }T
1470
1471 ; ----------------------------------------------------------------------------
1472 TESTING 2CONSTANT
1473
1474 T{ 1 2 2CONSTANT 2C1 -> }T
1475 T{ 2C1 -> 1 2 }T
1476 T{ : CD1 2C1 ; -> }T
1477 T{ CD1 -> 1 2 }T
1478 T{ : CD2 2CONSTANT ; -> }T
1479 T{ -1 -2 CD2 2C2 -> }T
1480 T{ 2C2 -> -1 -2 }T
1481 T{ 4 5 2CONSTANT 2C3 IMMEDIATE 2C3 -> 4 5 }T
1482 T{ : CD6 2C3 2LITERAL ; CD6 -> 4 5 }T
1483
1484 ; ----------------------------------------------------------------------------
1485 ; Some 2CONSTANTs for the following tests
1486
1487 1SD MAX-INTD 2CONSTANT MAX-2INT  \ 01...1
1488 0   MIN-INTD 2CONSTANT MIN-2INT  \ 10...0
1489 MAX-2INT 2/  2CONSTANT HI-2INT   \ 001...1
1490 MIN-2INT 2/  2CONSTANT LO-2INT   \ 110...0
1491
1492 ; ----------------------------------------------------------------------------
1493 TESTING DNEGATE
1494
1495 T{ 0. DNEGATE -> 0. }T
1496 T{ 1. DNEGATE -> -1. }T
1497 T{ -1. DNEGATE -> 1. }T
1498 T{ MAX-2INT DNEGATE -> MIN-2INT SWAP 1+ SWAP }T
1499 T{ MIN-2INT SWAP 1+ SWAP DNEGATE -> MAX-2INT }T
1500
1501 ; ----------------------------------------------------------------------------
1502 TESTING D+ with small integers
1503
1504 T{  0.  5. D+ ->  5. }T
1505 T{ -5.  0. D+ -> -5. }T
1506 T{  1.  2. D+ ->  3. }T
1507 T{  1. -2. D+ -> -1. }T
1508 T{ -1.  2. D+ ->  1. }T
1509 T{ -1. -2. D+ -> -3. }T
1510 T{ -1.  1. D+ ->  0. }T
1511
1512 TESTING D+ with mid range integers
1513
1514 T{  0  0  0  5 D+ ->  0  5 }T
1515 T{ -1  5  0  0 D+ -> -1  5 }T
1516 T{  0  0  0 -5 D+ ->  0 -5 }T
1517 T{  0 -5 -1  0 D+ -> -1 -5 }T
1518 T{  0  1  0  2 D+ ->  0  3 }T
1519 T{ -1  1  0 -2 D+ -> -1 -1 }T
1520 T{  0 -1  0  2 D+ ->  0  1 }T
1521 T{  0 -1 -1 -2 D+ -> -1 -3 }T
1522 T{ -1 -1  0  1 D+ -> -1  0 }T
1523 T{ MIN-INTD 0 2DUP D+ -> 0 1 }T
1524 T{ MIN-INTD S>D MIN-INTD 0 D+ -> 0 0 }T
1525
1526 TESTING D+ with large double integers
1527
1528 T{ HI-2INT 1. D+ -> 0 HI-INT 1+ }T
1529 T{ HI-2INT 2DUP D+ -> 1SD 1- MAX-INTD }T
1530 T{ MAX-2INT MIN-2INT D+ -> -1. }T
1531 T{ MAX-2INT LO-2INT D+ -> HI-2INT }T
1532 T{ HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T
1533 T{ LO-2INT 2DUP D+ -> MIN-2INT }T
1534
1535 ; ----------------------------------------------------------------------------
1536 TESTING D- with small integers
1537
1538 T{  0.  5. D- -> -5. }T
1539 T{  5.  0. D- ->  5. }T
1540 T{  0. -5. D- ->  5. }T
1541 T{  1.  2. D- -> -1. }T
1542 T{  1. -2. D- ->  3. }T
1543 T{ -1.  2. D- -> -3. }T
1544 T{ -1. -2. D- ->  1. }T
1545 T{ -1. -1. D- ->  0. }T
1546
1547 TESTING D- with mid-range integers
1548
1549 T{  0  0  0  5 D- ->  0 -5 }T
1550 T{ -1  5  0  0 D- -> -1  5 }T
1551 T{  0  0 -1 -5 D- ->  1  4 }T
1552 T{  0 -5  0  0 D- ->  0 -5 }T
1553 T{ -1  1  0  2 D- -> -1 -1 }T
1554 T{  0  1 -1 -2 D- ->  1  2 }T
1555 T{  0 -1  0  2 D- ->  0 -3 }T
1556 T{  0 -1  0 -2 D- ->  0  1 }T
1557 T{  0  0  0  1 D- ->  0 -1 }T
1558 T{ MIN-INTD 0 2DUP D- -> 0. }T
1559 T{ MIN-INTD S>D MAX-INTD 0 D- -> 1 1SD }T
1560
1561 TESTING D- with large integers
1562
1563 T{ MAX-2INT MAX-2INT D- -> 0. }T
1564 T{ MIN-2INT MIN-2INT D- -> 0. }T
1565 T{ MAX-2INT HI-2INT  D- -> LO-2INT DNEGATE }T
1566 T{ HI-2INT  LO-2INT  D- -> MAX-2INT }T
1567 T{ LO-2INT  HI-2INT  D- -> MIN-2INT 1. D+ }T
1568 T{ MIN-2INT MIN-2INT D- -> 0. }T
1569 T{ MIN-2INT LO-2INT  D- -> LO-2INT }T
1570
1571 ; ----------------------------------------------------------------------------
1572 TESTING D0< D0=
1573
1574 T{ 0. D0< -> FALSE }T
1575 T{ 1. D0< -> FALSE }T
1576 T{ MIN-INTD 0 D0< -> FALSE }T
1577 T{ 0 MAX-INTD D0< -> FALSE }T
1578 T{ MAX-2INT  D0< -> FALSE }T
1579 T{ -1. D0< -> TRUE }T
1580 T{ MIN-2INT D0< -> TRUE }T
1581
1582 T{ 1. D0= -> FALSE }T
1583 T{ MIN-INTD 0 D0= -> FALSE }T
1584 T{ MAX-2INT  D0= -> FALSE }T
1585 T{ -1 MAX-INTD D0= -> FALSE }T
1586 T{ 0. D0= -> TRUE }T
1587 T{ -1. D0= -> FALSE }T
1588 T{ 0 MIN-INTD D0= -> FALSE }T
1589
1590 ; ----------------------------------------------------------------------------
1591 TESTING D2* D2/
1592
1593 T{ 0. D2* -> 0. D2* }T
1594 T{ MIN-INTD 0 D2* -> 0 1 }T
1595 T{ HI-2INT D2* -> MAX-2INT 1. D- }T
1596 T{ LO-2INT D2* -> MIN-2INT }T
1597
1598 T{ 0. D2/ -> 0. }T
1599 T{ 1. D2/ -> 0. }T
1600 T{ 0 1 D2/ -> MIN-INTD 0 }T
1601 T{ MAX-2INT D2/ -> HI-2INT }T
1602 T{ -1. D2/ -> -1. }T
1603 T{ MIN-2INT D2/ -> LO-2INT }T
1604
1605 ; ----------------------------------------------------------------------------
1606 TESTING D< D=
1607
1608 T{  0.  1. D< -> TRUE  }T
1609 T{  0.  0. D< -> FALSE }T
1610 T{  1.  0. D< -> FALSE }T
1611 T{ -1.  1. D< -> TRUE  }T
1612 T{ -1.  0. D< -> TRUE  }T
1613 T{ -2. -1. D< -> TRUE  }T
1614 T{ -1. -2. D< -> FALSE }T
1615 T{ 0 1   1. D< -> FALSE }T  \ Suggested by Helmut Eller
1616 T{ 1.  0 1  D< -> TRUE  }T
1617 T{ 0 -1 1 -2 D< -> FALSE }T
1618 T{ 1 -2 0 -1 D< -> TRUE  }T
1619 T{ -1. MAX-2INT D< -> TRUE }T
1620 T{ MIN-2INT MAX-2INT D< -> TRUE }T
1621 T{ MAX-2INT -1. D< -> FALSE }T
1622 T{ MAX-2INT MIN-2INT D< -> FALSE }T
1623 T{ MAX-2INT 2DUP -1. D+ D< -> FALSE }T
1624 T{ MIN-2INT 2DUP  1. D+ D< -> TRUE  }T
1625 T{ MAX-INTD S>D 2DUP 1. D+ D< -> TRUE }T \ Ensure D< acts on MS cells
1626
1627 T{ -1. -1. D= -> TRUE  }T
1628 T{ -1.  0. D= -> FALSE }T
1629 T{ -1.  1. D= -> FALSE }T
1630 T{  0. -1. D= -> FALSE }T
1631 T{  0.  0. D= -> TRUE  }T
1632 T{  0.  1. D= -> FALSE }T
1633 T{  1. -1. D= -> FALSE }T
1634 T{  1.  0. D= -> FALSE }T
1635 T{  1.  1. D= -> TRUE  }T
1636
1637 T{ 0 -1 0 -1 D= -> TRUE  }T
1638 T{ 0 -1 0  0 D= -> FALSE }T
1639 T{ 0 -1 0  1 D= -> FALSE }T
1640 T{ 0  0 0 -1 D= -> FALSE }T
1641 T{ 0  0 0  0 D= -> TRUE  }T
1642 T{ 0  0 0  1 D= -> FALSE }T
1643 T{ 0  1 0 -1 D= -> FALSE }T
1644 T{ 0  1 0  0 D= -> FALSE }T
1645 T{ 0  1 0  1 D= -> TRUE  }T
1646
1647 T{ MAX-2INT MIN-2INT D= -> FALSE }T
1648 T{ MAX-2INT 0. D= -> FALSE }T
1649 T{ MAX-2INT MAX-2INT D= -> TRUE }T
1650 T{ MAX-2INT HI-2INT  D= -> FALSE }T
1651 T{ MAX-2INT MIN-2INT D= -> FALSE }T
1652 T{ MIN-2INT MIN-2INT D= -> TRUE }T
1653 T{ MIN-2INT LO-2INT  D=  -> FALSE }T
1654 T{ MIN-2INT MAX-2INT D= -> FALSE }T
1655
1656 ; ----------------------------------------------------------------------------
1657 TESTING 2LITERAL 2VARIABLE
1658
1659 T{ : CD3 [ MAX-2INT ] 2LITERAL ; -> }T
1660 T{ CD3 -> MAX-2INT }T
1661 T{ 2VARIABLE 2V1 -> }T
1662 T{ 0. 2V1 2! -> }T
1663 T{ 2V1 2@ -> 0. }T
1664 T{ -1 -2 2V1 2! -> }T
1665 T{ 2V1 2@ -> -1 -2 }T
1666 T{ : CD4 2VARIABLE ; -> }T
1667 T{ CD4 2V2 -> }T
1668 T{ : CD5 2V2 2! ; -> }T
1669 T{ -2 -1 CD5 -> }T
1670 T{ 2V2 2@ -> -2 -1 }T
1671 T{ 2VARIABLE 2V3 IMMEDIATE 5 6 2V3 2! -> }T
1672 T{ 2V3 2@ -> 5 6 }T
1673 T{ : CD7 2V3 [ 2@ ] 2LITERAL ; CD7 -> 5 6 }T
1674 T{ : CD8 [ 6 7 ] 2V3 [ 2! ] ; 2V3 2@ -> 6 7 }T
1675
1676 ; ----------------------------------------------------------------------------
1677 TESTING DMAX DMIN
1678
1679 T{  1.  2. DMAX -> 2. }T
1680 T{  1.  0. DMAX -> 1. }T
1681 T{  1. -1. DMAX -> 1. }T
1682 T{  1.  1. DMAX -> 1. }T
1683 T{  0.  1. DMAX -> 1. }T
1684 T{  0. -1. DMAX -> 0. }T
1685 T{ -1.  1. DMAX -> 1. }T
1686 T{ -1. -2. DMAX -> -1. }T
1687
1688 T{ MAX-2INT HI-2INT  DMAX -> MAX-2INT }T
1689 T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T
1690 T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T
1691 T{ MIN-2INT LO-2INT  DMAX -> LO-2INT  }T
1692
1693 T{ MAX-2INT  1. DMAX -> MAX-2INT }T
1694 T{ MAX-2INT -1. DMAX -> MAX-2INT }T
1695 T{ MIN-2INT  1. DMAX ->  1. }T
1696 T{ MIN-2INT -1. DMAX -> -1. }T
1697
1698
1699 T{  1.  2. DMIN ->  1. }T
1700 T{  1.  0. DMIN ->  0. }T
1701 T{  1. -1. DMIN -> -1. }T
1702 T{  1.  1. DMIN ->  1. }T
1703 T{  0.  1. DMIN ->  0. }T
1704 T{  0. -1. DMIN -> -1. }T
1705 T{ -1.  1. DMIN -> -1. }T
1706 T{ -1. -2. DMIN -> -2. }T
1707
1708 T{ MAX-2INT HI-2INT  DMIN -> HI-2INT  }T
1709 T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T
1710 T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T
1711 T{ MIN-2INT LO-2INT  DMIN -> MIN-2INT }T
1712
1713 T{ MAX-2INT  1. DMIN ->  1. }T
1714 T{ MAX-2INT -1. DMIN -> -1. }T
1715 T{ MIN-2INT  1. DMIN -> MIN-2INT }T
1716 T{ MIN-2INT -1. DMIN -> MIN-2INT }T
1717
1718 ; ----------------------------------------------------------------------------
1719 TESTING D>S DABS
1720
1721 T{  1234  0 D>S ->  1234 }T
1722 T{ -1234 -1 D>S -> -1234 }T
1723 T{ MAX-INTD  0 D>S -> MAX-INTD }T
1724 T{ MIN-INTD -1 D>S -> MIN-INTD }T
1725
1726 T{  1. DABS -> 1. }T
1727 T{ -1. DABS -> 1. }T
1728 T{ MAX-2INT DABS -> MAX-2INT }T
1729 T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T
1730
1731 ; ----------------------------------------------------------------------------
1732 TESTING M+ M*/
1733
1734 T{ HI-2INT   1 M+ -> HI-2INT   1. D+ }T
1735 T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T
1736 T{ MIN-2INT  1 M+ -> MIN-2INT  1. D+ }T
1737 T{ LO-2INT  -1 M+ -> LO-2INT  -1. D+ }T
1738
1739 ; To correct the result if the division is floored, only used when
1740 ; necessary i.e. negative quotient and remainder <> 0
1741
1742 : ?FLOORED [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ;
1743
1744 T{  5.  7 11 M*/ ->  3. }T
1745 T{  5. -7 11 M*/ -> -3. ?FLOORED }T    \ FLOORED -4.
1746 T{ -5.  7 11 M*/ -> -3. ?FLOORED }T    \ FLOORED -4.
1747 T{ -5. -7 11 M*/ ->  3. }T
1748 T{ MAX-2INT  8 16 M*/ -> HI-2INT }T
1749 T{ MAX-2INT -8 16 M*/ -> HI-2INT DNEGATE ?FLOORED }T  \ FLOORED SUBTRACT 1
1750 T{ MIN-2INT  8 16 M*/ -> LO-2INT }T
1751 T{ MIN-2INT -8 16 M*/ -> LO-2INT DNEGATE }T
1752 T{ MAX-2INT MAX-INTD MAX-INTD M*/ -> MAX-2INT }T
1753 T{ MAX-2INT MAX-INTD 2/ MAX-INTD M*/ -> MAX-INTD 1- HI-2INT NIP }T
1754 T{ MIN-2INT LO-2INT NIP 1+ DUP 1- NEGATE M*/ -> 0 MAX-INTD 1- }T
1755 T{ MIN-2INT LO-2INT NIP 1- MAX-INTD M*/ -> MIN-INTD 3 + HI-2INT NIP 2 + }T
1756 T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T
1757 T{ MIN-2INT MAX-INTD DUP M*/ -> MIN-2INT }T
1758
1759 ; ----------------------------------------------------------------------------
1760 TESTING D. D.R
1761
1762 ; Create some large double numbers
1763 MAX-2INT 71 73 M*/ 2CONSTANT DBL1
1764 MIN-2INT 73 79 M*/ 2CONSTANT DBL2
1765
1766 : D>ASCII  ( D -- CADDR U )
1767    DUP >R <# DABS #S R> SIGN #>    ( -- CADDR1 U )
1768    HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R>
1769 ;
1770
1771 DBL1 D>ASCII 2CONSTANT "DBL1"
1772 DBL2 D>ASCII 2CONSTANT "DBL2"
1773
1774 : DOUBLEOUTPUT
1775    CR ." You should see lines duplicated:" CR
1776    5 SPACES "DBL1" TYPE CR
1777    5 SPACES DBL1 D. CR
1778    8 SPACES "DBL1" DUP >R TYPE CR
1779    5 SPACES DBL1 R> 3 + D.R CR
1780    5 SPACES "DBL2" TYPE CR
1781    5 SPACES DBL2 D. CR
1782    10 SPACES "DBL2" DUP >R TYPE CR
1783    5 SPACES DBL2 R> 5 + D.R CR
1784 ;
1785
1786 T{ DOUBLEOUTPUT -> }T
1787 ; ----------------------------------------------------------------------------
1788 TESTING 2ROT DU< (Double Number extension words)
1789
1790 T{ 1. 2. 3. 2ROT -> 2. 3. 1. }T
1791 T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T
1792
1793 T{  1.  1. DU< -> FALSE }T
1794 T{  1. -1. DU< -> TRUE  }T
1795 T{ -1.  1. DU< -> FALSE }T
1796 T{ -1. -2. DU< -> FALSE }T
1797 T{ 0 1   1. DU< -> FALSE }T
1798 T{ 1.  0 1  DU< -> TRUE  }T
1799 T{ 0 -1 1 -2 DU< -> FALSE }T
1800 T{ 1 -2 0 -1 DU< -> TRUE  }T
1801
1802 T{ MAX-2INT HI-2INT  DU< -> FALSE }T
1803 T{ HI-2INT  MAX-2INT DU< -> TRUE  }T
1804 T{ MAX-2INT MIN-2INT DU< -> TRUE }T
1805 T{ MIN-2INT MAX-2INT DU< -> FALSE }T
1806 T{ MIN-2INT LO-2INT  DU< -> TRUE }T
1807
1808 ; ----------------------------------------------------------------------------
1809 TESTING 2VALUE
1810
1811 T{ 1111 2222 2VALUE 2VAL -> }T
1812 T{ 2VAL -> 1111 2222 }T
1813 T{ 3333 4444 TO 2VAL -> }T
1814 T{ 2VAL -> 3333 4444 }T
1815 T{ : TO-2VAL TO 2VAL ; 5555 6666 TO-2VAL -> }T
1816 T{ 2VAL -> 5555 6666 }T
1817
1818 CR .( End of Double-Number word tests) CR