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