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