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 #307,TOS            \ FastForth V3.7
  40 COLON
  41 $0D EMIT    \ return to column 1 without CR
  42 ABORT" FastForth version = 3.7 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     S< 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     BIT #UF9,SR
 593     0= IF
 594         BIS #UF9,SR
 595     ELSE
 596         BIC #UF9,SR
 597     THEN
 598 THEN                        \ let's process UM*     -- ud1lo ud1hi u1 +n2
 599             MOV 4(PSP),Y            \ 3 uMDlo
 600             MOV 2(PSP),T            \ 3 uMDhi
 601             MOV @PSP+,S             \ 2 uMRlo        -- ud1lo ud1hi +n2
 602             MOV #0,rDODOES          \ 1 uMDlo=0
 603             MOV #0,2(PSP)           \ 3 uRESlo=0
 604             MOV #0,0(PSP)           \ 3 uRESmi=0     -- uRESlo uRESmi +n2
 605             MOV #0,W                \ 1 uREShi=0
 606             MOV #1,X                \ 1 BIT TEST REGlo
 607 BEGIN       BIT X,S                 \ 1 test actual bit in uMRlo
 608     0<> IF  ADD Y,2(PSP)            \ 3 IF 1: ADD uMDlo TO uRESlo
 609             ADDC T,0(PSP)           \ 3      ADDC uMDmi TO uRESmi
 610             ADDC rDODOES,W          \ 1      ADDC uMRlo TO uREShi
 611     THEN    ADD Y,Y                 \ 1 (RLA LSBs) uMDlo *2
 612             ADDC T,T                \ 1 (RLC MSBs) uMDhi *2
 613             ADDC rDODOES,rDODOES    \ 1 (RLA LSBs) uMDlo *2
 614             ADD X,X                 \ 1 (RLA) NEXT BIT TO TEST
 615 U>= UNTIL                           \ 1 IF BIT IN CARRY: FINISHED   W=uREShi
 616 \ TOS     +n2
 617 \ W       REShi
 618 \ 0(PSP)  RESmi
 619 \ 2(PSP)  RESlo
 620 MOV TOS,T
 621 MOV @PSP,TOS
 622 MOV 2(PSP),S
 623 \ reg     division     output
 624 \ --------------------------
 625 \ S     = DVD(15-0)
 626 \ TOS   = DVD(31-16)
 627 \ T     = DIV(15-0)
 628 \ W     = 0|DVD(47-32)  REM
 629 \ X     = 0             QUOTlo
 630 \ Y     = 0             QUOThi
 631 \ rDODOES = count
 632 \ 2(PSP)                REM
 633 \ 0(PSP)                QUOTlo
 634 \ TOS                   QUOThi
 635 MOV #32,rDODOES         \ 2  init loop count
 636 CMP #0,W                \ DVDhi = 0 ?
 637 0= IF                   \ if yes
 638     MOV TOS,W           \ DVDmi --> DVDhi
 639     CALL #MDIV1DIV2     \ with loop count / 2
 640 ELSE
 641     CALL #MDIV1         \ -- urem ud2lo ud2hi
 642 THEN
 643 MOV @PSP+,0(PSP)        \ -- ud2lo ud2hi
 644 BIT #UF9,SR             \ sign is set ?
 645 0<> IF                  \ DNEGATE
 646     XOR #-1,0(PSP)
 647     XOR #-1,TOS
 648     ADD #1,0(PSP)
 649     ADDC #0,TOS
 650     BIC #UF9,SR         \ clear sign flag
 651 \ now, make floored division, only used if rem<>0 and quot<0 :
 652     CMP #0,W            \ remainder <> 0 ?
 653     0<> IF
 654         SUB #1,0(PSP)   \ decrement quotient
 655         SUBC #0,TOS
 656     THEN
 657 THEN
 658 MOV @IP+,PC             \ 4
 659 ENDCODE
 660 [THEN]
 661
 662 [ELSE]  \ hardware multiplier
 663
 664 [UNDEFINED] M*/ [IF]
 665 \ https://forth-standard.org/standard/double/MTimesDiv
 666 CODE M*/                \ d1 * n1 / +n2 -- d2
 667 MOV 4(PSP),&MPYS32L     \ 5             Load 1st operand    d1lo
 668 MOV 2(PSP),&MPYS32H     \ 5                                 d1hi
 669 MOV @PSP+,&OP2          \ 4 -- d1 n2    load 2nd operand    n1
 670 MOV TOS,T               \ T = DIV
 671 NOP3
 672 MOV &RES0,S             \ 3 S = RESlo
 673 MOV &RES1,TOS           \ 3 TOS = RESmi
 674 MOV &RES2,W             \ 3 W = REShi
 675 BIC #UF9,SR             \ clear sign flag
 676 CMP #0,W                \ negative product ?
 677 S< IF                   \ DABS if yes
 678     XOR #-1,S
 679     XOR #-1,TOS
 680     XOR #-1,W
 681     ADD #1,S
 682     ADDC #0,TOS
 683     ADDC #0,W
 684     BIS #UF9,SR         \ set sign flag
 685 THEN
 686 \ reg     division     output
 687 \ --------------------------
 688 \ S     = DVD(15-0)
 689 \ TOS   = DVD(31-16)
 690 \ T     = DIV(15-0)
 691 \ W     = 0|DVD(47-32)  REM
 692 \ X     = 0             QUOTlo
 693 \ Y     = 0             QUOThi
 694 \ rDODOES = count
 695 \ 2(PSP)                REM
 696 \ 0(PSP)                QUOTlo
 697 \ TOS                   QUOThi
 698 MOV #32,rDODOES         \ 2  init loop count
 699 CMP #0,W                \ DVDhi = 0 ?
 700 0= IF                   \ if yes
 701     MOV TOS,W           \ DVDmi --> DVDhi
 702     CALL #MDIV1DIV2     \ with loop count / 2
 703 ELSE
 704     CALL #MDIV1         \ -- urem ud2lo ud2hi
 705 THEN
 706 MOV @PSP+,0(PSP)        \ -- d2lo d2hi
 707 BIT #UF9,SR             \ RES sign is set ?
 708 0<> IF                  \ DNEGATE
 709     XOR #-1,0(PSP)
 710     XOR #-1,TOS
 711     ADD #1,0(PSP)
 712     ADDC #0,TOS
 713     BIC #UF9,SR         \ clear sign flag
 714 \ now, make floored division, only used if rem<>0 and quot<0 :
 715     CMP #0,W            \ remainder <> 0 ?
 716     0<> IF
 717         SUB #1,0(PSP)   \ decrement quotient
 718         SUBC #0,TOS
 719     THEN
 720 THEN
 721 MOV @IP+,PC             \ 52 words
 722 ENDCODE
 723 [THEN]
 724
 725 [THEN]  ; end of software/hardware_MPY
 726
 727 [UNDEFINED] 2VARIABLE [IF]
 728 \ https://forth-standard.org/standard/double/TwoVARIABLE
 729 : 2VARIABLE \  --
 730 CREATE
 731 HI2LO
 732 ADD #4,&DP
 733 MOV @RSP+,IP
 734 NEXT
 735 ENDCODE
 736 [THEN]
 737
 738 [UNDEFINED] 2CONSTANT [IF]
 739 \ https://forth-standard.org/standard/double/TwoCONSTANT
 740 : 2CONSTANT \  udlo/dlo/Flo udhi/dhi/Shi --         to create double or s15q16 CONSTANT
 741 CREATE
 742 , ,             \ compile Shi then Flo
 743 DOES>
 744 2@              \ execution part
 745 ;
 746 [THEN]
 747
 748 [UNDEFINED] 2VALUE [IF]
 749 \ https://forth-standard.org/standard/double/TwoVALUE
 750 : 2VALUE        \ x1 x2 "<spaces>name" --
 751 CREATE , ,      \ compile Shi then Flo
 752 DOES>
 753 HI2LO
 754 MOV @RSP+,IP
 755 BIT #UF9,SR     \ flag set by TO
 756 0= IF
 757    MOV #2@,PC   \ execute TwoFetch
 758 THEN
 759 BIC #UF9,SR     \ clear flag
 760 MOV #2!,PC      \ execute TwoStore
 761 ENDCODE
 762 [THEN]
 763
 764 [UNDEFINED] 2LITERAL [IF]
 765 \ https://forth-standard.org/standard/double/TwoLITERAL
 766 CODE 2LITERAL
 767 BIS #UF9,SR     \ see LITERAL
 768 MOV #LITERAL,PC
 769 ENDCODE IMMEDIATE
 770 [THEN]
 771
 772 [UNDEFINED] D.R [IF]
 773 \ https://forth-standard.org/standard/double/DDotR
 774 \ D.R       d n --
 775 : D.R
 776 >R SWAP OVER DABS <# #S ROT SIGN #>
 777 R> OVER - SPACES TYPE
 778 ;
 779 [THEN]
 780
 781 [THEN] \ end of {DOUBLE}
 782
 783 RST_HERE
 784
 785 \ ------------------------------------------------------------------------------
 786 \ ------------------------------------------------------------------------------
 787 \ Complement to test DOUBLE
 788 \ ------------------------------------------------------------------------------
 789 \ ------------------------------------------------------------------------------
 790
 791 [UNDEFINED] VARIABLE [IF]
 792 \ https://forth-standard.org/standard/core/VARIABLE
 793 : VARIABLE \  --
 794 CREATE
 795 HI2LO
 796 MOV @RSP+,IP
 797 ADD #2,&DP
 798 NEXT
 799 ENDCODE
 800 [THEN]
 801
 802 [UNDEFINED] CONSTANT [IF]
 803 \ https://forth-standard.org/standard/core/CONSTANT
 804 \ CONSTANT <name>     n --                      define a Forth CONSTANT
 805 : CONSTANT
 806 CREATE
 807 HI2LO
 808 MOV TOS,-2(W)           \   PFA = n
 809 MOV @PSP+,TOS
 810 MOV @RSP+,IP
 811 MOV @IP+,PC
 812 ENDCODE
 813 [THEN]
 814
 815 [UNDEFINED] CELLS [IF]
 816 \ https://forth-standard.org/standard/core/CELLS
 817 \ CELLS    n1 -- n2            cells->adrs units
 818 CODE CELLS
 819 ADD TOS,TOS
 820 MOV @IP+,PC
 821 ENDCODE
 822 [THEN]
 823
 824 [UNDEFINED] ALLOT [IF]
 825 \ https://forth-standard.org/standard/core/ALLOT
 826 \ ALLOT   n --         allocate n bytes
 827 CODE ALLOT
 828 ADD TOS,&DP
 829 MOV @PSP+,TOS
 830 MOV @IP+,PC
 831 ENDCODE
 832 [THEN]
 833
 834 [UNDEFINED] DEPTH [IF]
 835 \ https://forth-standard.org/standard/core/DEPTH
 836 \ DEPTH    -- +n        number of items on stack, must leave 0 if stack empty
 837 CODE DEPTH
 838 MOV TOS,-2(PSP)
 839 MOV #PSTACK,TOS
 840 SUB PSP,TOS     \ PSP-S0--> TOS
 841 RRA TOS         \ TOS/2   --> TOS
 842 SUB #2,PSP      \ post decrement stack...
 843 MOV @IP+,PC
 844 ENDCODE
 845 [THEN]
 846
 847 [UNDEFINED] DUP [IF]
 848 \ https://forth-standard.org/standard/core/DUP
 849 \ DUP      x -- x x      duplicate top of stack
 850 CODE DUP
 851 BW1 SUB #2,PSP      \ 2  push old TOS..
 852     MOV TOS,0(PSP)  \ 3  ..onto stack
 853     MOV @IP+,PC     \ 4
 854 ENDCODE
 855
 856 \ https://forth-standard.org/standard/core/qDUP
 857 \ ?DUP     x -- 0 | x x    DUP if nonzero
 858 CODE ?DUP
 859 CMP #0,TOS      \ 2  test for TOS nonzero
 860 0<> ?GOTO BW1    \ 2
 861 MOV @IP+,PC     \ 4
 862 ENDCODE
 863 [THEN]
 864
 865 [UNDEFINED] DO [IF]     \ define DO LOOP +LOOP
 866 \ https://forth-standard.org/standard/core/DO
 867 \ DO       -- DOadr   L: -- 0
 868 CODE DO                 \ immediate
 869 SUB #2,PSP              \
 870 MOV TOS,0(PSP)          \
 871 ADD #2,&DP              \   make room to compile xdo
 872 MOV &DP,TOS             \ -- HERE+2
 873 MOV #XDO,-2(TOS)        \   compile xdo
 874 ADD #2,&LEAVEPTR        \ -- HERE+2     LEAVEPTR+2
 875 MOV &LEAVEPTR,W         \
 876 MOV #0,0(W)             \ -- HERE+2     L-- 0
 877 MOV @IP+,PC
 878 ENDCODE IMMEDIATE
 879
 880 \ https://forth-standard.org/standard/core/LOOP
 881 \ LOOP    DOadr --         L-- an an-1 .. a1 0
 882 CODE LOOP               \ immediate
 883     MOV #XLOOP,X
 884 BW1 ADD #4,&DP          \ make room to compile two words
 885     MOV &DP,W
 886     MOV X,-4(W)         \ xloop --> HERE
 887     MOV TOS,-2(W)       \ DOadr --> HERE+2
 888 BEGIN                   \ resolve all "leave" adr
 889     MOV &LEAVEPTR,TOS   \ -- Adr of top LeaveStack cell
 890     SUB #2,&LEAVEPTR    \ --
 891     MOV @TOS,TOS        \ -- first LeaveStack value
 892     CMP #0,TOS          \ -- = value left by DO ?
 893 0<> WHILE
 894     MOV W,0(TOS)        \ move adr after loop as UNLOOP adr
 895 REPEAT
 896     MOV @PSP+,TOS
 897     MOV @IP+,PC
 898 ENDCODE IMMEDIATE
 899
 900 \ https://forth-standard.org/standard/core/PlusLOOP
 901 \ +LOOP   adrs --   L-- an an-1 .. a1 0
 902 CODE +LOOP              \ immediate
 903 MOV #XPLOOP,X
 904 GOTO BW1
 905 ENDCODE IMMEDIATE
 906 [THEN]
 907
 908 [UNDEFINED] I [IF]
 909 \ https://forth-standard.org/standard/core/I
 910 \ I        -- n   R: sys1 sys2 -- sys1 sys2
 911 \                  get the innermost loop index
 912 CODE I
 913 SUB #2,PSP              \ 1 make room in TOS
 914 MOV TOS,0(PSP)          \ 3
 915 MOV @RSP,TOS            \ 2 index = loopctr - fudge
 916 SUB 2(RSP),TOS          \ 3
 917 MOV @IP+,PC             \ 4 13~
 918 ENDCODE
 919 [THEN]
 920
 921 [UNDEFINED] + [IF]
 922 \ https://forth-standard.org/standard/core/Plus
 923 \ +       n1/u1 n2/u2 -- n3/u3     add n1+n2
 924 CODE +
 925 ADD @PSP+,TOS
 926 MOV @IP+,PC
 927 ENDCODE
 928 [THEN]
 929
 930 [UNDEFINED] = [IF]
 931 \ https://forth-standard.org/standard/core/Equal
 932 \ =      x1 x2 -- flag         test x1=x2
 933 CODE =
 934 SUB @PSP+,TOS   \ 2
 935 0<> IF          \ 2
 936     AND #0,TOS  \ 1
 937     MOV @IP+,PC \ 4
 938 THEN
 939 XOR #-1,TOS     \ 1 flag Z = 1
 940 MOV @IP+,PC     \ 4
 941 ENDCODE
 942 [THEN]
 943
 944 [UNDEFINED] 0= [IF]
 945 \ https://forth-standard.org/standard/core/ZeroEqual
 946 \ 0=     n/u -- flag    return true if TOS=0
 947 CODE 0=
 948 SUB #1,TOS      \ borrow (clear cy) if TOS was 0
 949 SUBC TOS,TOS    \ TOS=-1 if borrow was set
 950 MOV @IP+,PC
 951 ENDCODE
 952 [THEN]
 953
 954 [UNDEFINED] SOURCE [IF]
 955 \ https://forth-standard.org/standard/core/SOURCE
 956 \ SOURCE    -- adr u    of current input buffer
 957 CODE SOURCE
 958 SUB #4,PSP
 959 MOV TOS,2(PSP)
 960 MOV &SOURCE_LEN,TOS
 961 MOV &SOURCE_ORG,0(PSP)
 962 MOV @IP+,PC
 963 ENDCODE
 964 [THEN]
 965
 966 [UNDEFINED] >IN [IF]
 967 \ https://forth-standard.org/standard/core/toIN
 968 \ C >IN     -- a-addr       holds offset in input stream
 969 TOIN CONSTANT >IN
 970 [THEN]
 971
 972 [UNDEFINED] SWAP [IF]
 973 \ https://forth-standard.org/standard/core/SWAP
 974 \ SWAP     x1 x2 -- x2 x1    swap top two items
 975 CODE SWAP
 976 MOV @PSP,W      \ 2
 977 MOV TOS,0(PSP)  \ 3
 978 MOV W,TOS       \ 1
 979 MOV @IP+,PC     \ 4
 980 ENDCODE
 981 [THEN]
 982
 983 [UNDEFINED] DROP [IF]
 984 \ https://forth-standard.org/standard/core/DROP
 985 \ DROP     x --          drop top of stack
 986 CODE DROP
 987 MOV @PSP+,TOS   \ 2
 988 MOV @IP+,PC     \ 4
 989 ENDCODE
 990 [THEN]
 991
 992 [UNDEFINED] 1+ [IF]
 993 \ https://forth-standard.org/standard/core/OnePlus
 994 \ 1+      n1/u1 -- n2/u2       add 1 to TOS
 995 CODE 1+
 996 ADD #1,TOS
 997 MOV @IP+,PC
 998 ENDCODE
 999 [THEN]
1000
1001 [UNDEFINED] CHAR [IF]
1002 \ https://forth-standard.org/standard/core/CHAR
1003 \ CHAR   -- char           parse ASCII character
1004 : CHAR
1005     $20 WORD 1+ C@
1006 ;
1007 [THEN]
1008
1009 [UNDEFINED] [CHAR] [IF]
1010 \ https://forth-standard.org/standard/core/BracketCHAR
1011 \ [CHAR]   --          compile character literal
1012 : [CHAR]
1013     CHAR POSTPONE LITERAL
1014 ; IMMEDIATE
1015 [THEN]
1016
1017 [UNDEFINED] 2/ [IF]
1018 \ https://forth-standard.org/standard/core/TwoDiv
1019 \ 2/      x1 -- x2        arithmetic right shift
1020 CODE 2/
1021 RRA TOS
1022 MOV @IP+,PC
1023 ENDCODE
1024 [THEN]
1025
1026 [UNDEFINED] INVERT [IF]
1027 \ https://forth-standard.org/standard/core/INVERT
1028 \ INVERT   x1 -- x2            bitwise inversion
1029 CODE INVERT
1030 XOR #-1,TOS
1031 MOV @IP+,PC
1032 ENDCODE
1033 [THEN]
1034
1035 [UNDEFINED] RSHIFT [IF]
1036 \ https://forth-standard.org/standard/core/RSHIFT
1037 \ RSHIFT  x1 u -- x2    logical R7 shift u places
1038 CODE RSHIFT
1039             MOV @PSP+,W
1040             AND #$1F,TOS       \ no need to shift more than 16
1041 0<> IF
1042     BEGIN   BIC #C,SR           \ Clr Carry
1043             RRC W
1044             SUB #1,TOS
1045     0= UNTIL
1046 THEN        MOV W,TOS
1047             MOV @IP+,PC
1048 ENDCODE
1049 [THEN]
1050
1051 [UNDEFINED] 0< [IF]
1052 \ https://forth-standard.org/standard/core/Zeroless
1053 \ 0<     n -- flag      true if TOS negative
1054 CODE 0<
1055 ADD TOS,TOS     \ 1 set carry if TOS negative
1056 SUBC TOS,TOS    \ 1 TOS=-1 if carry was clear
1057 XOR #-1,TOS     \ 1 TOS=-1 if carry was set
1058 MOV @IP+,PC     \
1059 ENDCODE
1060 [THEN]
1061
1062 [UNDEFINED] S>D [IF]
1063 \ https://forth-standard.org/standard/core/StoD
1064 \ S>D    n -- d          single -> double prec.
1065 : S>D
1066     DUP 0<
1067 ;
1068 [THEN]
1069
1070 [UNDEFINED] 1- [IF]
1071 \ https://forth-standard.org/standard/core/OneMinus
1072 \ 1-      n1/u1 -- n2/u2     subtract 1 from TOS
1073 CODE 1-
1074 SUB #1,TOS
1075 MOV @IP+,PC
1076 ENDCODE
1077 [THEN]
1078
1079 [UNDEFINED] UM/MOD [IF]
1080 \ https://forth-standard.org/standard/core/UMDivMOD
1081 \ UM/MOD   udlo|udhi u1 -- r q   unsigned 32/16->r16 q16
1082 CODE UM/MOD
1083     PUSH #DROP      \
1084     MOV #MUSMOD,PC  \ execute MUSMOD then return to DROP
1085 ENDCODE
1086 [THEN]
1087
1088 [UNDEFINED] SM/REM [IF]
1089 \ https://forth-standard.org/standard/core/SMDivREM
1090 \ SM/REM   DVDlo DVDhi DIVlo -- r3 q4  symmetric signed div
1091 CODE SM/REM
1092 MOV TOS,S           \           S=DIVlo
1093 MOV @PSP,T          \           T=DVD_sign==>rem_sign
1094 CMP #0,TOS          \           n2 >= 0 ?
1095 S< IF               \
1096     XOR #-1,TOS
1097     ADD #1,TOS      \ -- d1 u2
1098 THEN
1099 CMP #0,0(PSP)       \           d1hi >= 0 ?
1100 S< IF               \
1101     XOR #-1,2(PSP)  \           d1lo
1102     XOR #-1,0(PSP)  \           d1hi
1103     ADD #1,2(PSP)   \           d1lo+1
1104     ADDC #0,0(PSP)  \           d1hi+C
1105 THEN                \ -- uDVDlo uDVDhi uDIVlo
1106 PUSHM #3,IP         \           save IP,S,T
1107 LO2HI
1108     UM/MOD          \ -- uREMlo uQUOTlo
1109 HI2LO
1110 POPM #3,IP          \           restore T,S,IP
1111 CMP #0,T            \           T=rem_sign
1112 S< IF
1113     XOR #-1,0(PSP)
1114     ADD #1,0(PSP)
1115 THEN
1116 XOR S,T             \           S=divisor T=quot_sign
1117 CMP #0,T            \ -- n3 u4  T=quot_sign
1118 S< IF
1119     XOR #-1,TOS
1120     ADD #1,TOS
1121 THEN                \ -- n3 n4  S=divisor
1122 MOV @IP+,PC
1123 ENDCODE
1124 [THEN]
1125
1126 [UNDEFINED] FM/MOD [IF]
1127 \ https://forth-standard.org/standard/core/FMDivMOD
1128 \ FM/MOD   d1 n1 -- r q   floored signed div'n
1129 : FM/MOD
1130 SM/REM
1131 HI2LO               \ -- remainder quotient       S=divisor
1132 CMP #0,0(PSP)       \ remainder <> 0 ?
1133 0<> IF
1134     CMP #1,TOS      \ quotient < 1 ?
1135     S< IF
1136       ADD S,0(PSP)  \ add divisor to remainder
1137       SUB #1,TOS    \ decrement quotient
1138     THEN
1139 THEN
1140 MOV @RSP+,IP
1141 MOV @IP+,PC
1142 ENDCODE
1143 [THEN]
1144
1145 [UNDEFINED] NIP [IF]
1146 \ https://forth-standard.org/standard/core/NIP
1147 \ NIP      x1 x2 -- x2         Drop the first item below the top of stack
1148 CODE NIP
1149 ADD #2,PSP
1150 MOV @IP+,PC
1151 ENDCODE
1152 [THEN]
1153
1154 [UNDEFINED] / [IF]
1155 \ https://forth-standard.org/standard/core/Div
1156 \ /      n1 n2 -- n3       signed quotient
1157 : /
1158 >R DUP 0< R> FM/MOD NIP
1159 ;
1160 [THEN]
1161
1162 [UNDEFINED] NEGATE [IF]
1163 \ https://forth-standard.org/standard/core/NEGATE
1164 \ C NEGATE   x1 -- x2            two's complement
1165 CODE NEGATE
1166 XOR #-1,TOS
1167 ADD #1,TOS
1168 MOV @IP+,PC
1169 ENDCODE
1170 [THEN]
1171
1172 [UNDEFINED] HERE [IF]
1173 CODE HERE
1174 MOV #HEREXEC,PC
1175 ENDCODE
1176 [THEN]
1177
1178 [UNDEFINED] CHARS [IF]
1179 \ https://forth-standard.org/standard/core/CHARS
1180 \ CHARS    n1 -- n2            chars->adrs units
1181 CODE CHARS
1182 MOV @IP+,PC
1183 ENDCODE
1184 [THEN]
1185
1186 [UNDEFINED] MOVE [IF]
1187 \ https://forth-standard.org/standard/core/MOVE
1188 \ MOVE    addr1 addr2 u --     smart move
1189 \             VERSION FOR 1 ADDRESS UNIT = 1 CHAR
1190 CODE MOVE
1191 MOV TOS,W           \ W = cnt
1192 MOV @PSP+,Y         \ Y = addr2 = dst
1193 MOV @PSP+,X         \ X = addr1 = src
1194 MOV @PSP+,TOS       \ pop new TOS
1195 CMP #0,W            \ count = 0 ?
1196 0<> IF              \ if 0, already done !
1197     CMP X,Y         \ Y-X \ dst - src
1198     0<> IF          \ else already done !
1199         U< IF       \ U< if src > dst
1200             BEGIN   \ copy W bytes
1201                 MOV.B @X+,0(Y)
1202                 ADD #1,Y
1203                 SUB #1,W
1204             0= UNTIL
1205             MOV @IP+,PC \ out 1 of MOVE ====>
1206         THEN        \ U>= if dst > src
1207         ADD W,Y     \ copy W bytes beginning with the end
1208         ADD W,X
1209         BEGIN
1210             SUB #1,X
1211             SUB #1,Y
1212             MOV.B @X,0(Y)
1213             SUB #1,W
1214         0= UNTIL
1215     THEN
1216 THEN
1217 MOV @IP+,PC \ out 2 of MOVE ====>
1218 ENDCODE
1219 [THEN]
1220
1221  0 CONSTANT FALSE
1222 -1 CONSTANT TRUE
1223
1224 \ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
1225 \ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
1226 VARIABLE VERBOSE
1227     FALSE VERBOSE !
1228 \   TRUE VERBOSE !
1229
1230 \ : EMPTY-STACK ( ... -- )  \ EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
1231 \     DEPTH ?DUP
1232 \             IF DUP 0< IF NEGATE 0
1233 \             DO 0 LOOP
1234 \             ELSE 0 DO DROP LOOP THEN
1235 \             THEN ;
1236 \
1237 \ : ERROR     \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
1238 \         \ THE LINE THAT HAD THE ERROR.
1239 \     TYPE SOURCE TYPE CR          \ DISPLAY LINE CORRESPONDING TO ERROR
1240 \     EMPTY-STACK              \ THROW AWAY EVERY THING ELSE
1241 \     QUIT  \ *** Uncomment this line to QUIT on an error
1242 \ ;
1243
1244 VARIABLE ACTUAL-DEPTH           \ STACK RECORD
1245 CREATE ACTUAL-RESULTS 20 CELLS ALLOT
1246
1247 : T{        \ ( -- ) SYNTACTIC SUGAR.
1248     ;
1249
1250 : ->        \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
1251     DEPTH DUP ACTUAL-DEPTH !     \ RECORD DEPTH
1252     ?DUP IF              \ IF THERE IS SOMETHING ON STACK
1253         0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
1254     THEN ;
1255
1256 : }T        \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
1257             \ (ACTUAL) CONTENTS.
1258     DEPTH ACTUAL-DEPTH @ = IF   \ IF DEPTHS MATCH
1259         DEPTH ?DUP IF           \ IF THERE IS SOMETHING ON THE STACK
1260         0 DO                    \ FOR EACH STACK ITEM
1261             ACTUAL-RESULTS I CELLS + @  \ COMPARE ACTUAL WITH EXPECTED
1262 \           = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN \ jmt
1263             = 0= IF TRUE ABORT" INCORRECT RESULT" THEN      \ jmt : abort with colorised message
1264         LOOP
1265         THEN
1266     ELSE                 \ DEPTH MISMATCH
1267 \       S" WRONG NUMBER OF RESULTS: " ERROR     \ jmt
1268         TRUE ABORT" WRONG NUMBER OF RESULTS"    \ jmt : abort with colorised message
1269     THEN ;
1270
1271 : TESTING   \ ( -- ) TALKING COMMENT.
1272     SOURCE VERBOSE @
1273     IF DUP >R TYPE CR R> >IN !
1274     ELSE >IN ! DROP [CHAR] * EMIT
1275     THEN ;
1276
1277 -1 CONSTANT 1S
1278 0 CONSTANT <FALSE>
1279 -1 CONSTANT <TRUE>
1280 0 INVERT 1 RSHIFT           CONSTANT MAX-INT    ; %011...1
1281 0 INVERT 1 RSHIFT INVERT    CONSTANT MIN-INT    ; %100...0
1282 MAX-INT 2/                  CONSTANT HI-INT     ; %001...1
1283 MIN-INT 2/                  CONSTANT LO-INT     ; %110...0
1284 -1 MAX-INT                  2CONSTANT MAX-2INT  ; %.011...1
1285 0 MIN-INT                   2CONSTANT MIN-2INT  ; %.100...0
1286 MAX-2INT 2/                 2CONSTANT HI-2INT   ; %.001...1
1287 MIN-2INT 2/                 2CONSTANT LO-2INT   ; %.110...0
1288
1289 ECHO
1290
1291 ; -----------------------------------------------------------------------------
1292 ; DOUBLE tests
1293 ; -----------------------------------------------------------------------------
1294
1295 \ MAX-INT .
1296 \ MIN-INT .
1297 \ HI-INT .
1298 \ LO-INT .
1299 \ MAX-2INT D.
1300 \ MIN-2INT D.
1301 \ HI-2INT D.
1302 \ LO-2INT D.
1303 \
1304 \ 2CONSTANT
1305 T{ 1 2 2CONSTANT 2c1 -> }T
1306 T{ 2c1 -> 1 2 }T
1307 T{ : cd1 2c1 ; -> }T
1308 T{ cd1 -> 1 2 }T
1309
1310 T{ : cd2 2CONSTANT ; -> }T
1311 T{ -1 -2 cd2 2c2 -> }T
1312 T{ 2c2 -> -1 -2 }T
1313
1314 T{ 4 5 2CONSTANT 2c3 IMMEDIATE 2c3 -> 4 5 }T
1315 T{ : cd6 2c3 2LITERAL ; cd6 -> 4 5 }T
1316
1317 \ 2VARIABLE
1318 T{ 2VARIABLE 2v1 -> }T
1319 T{ 0. 2v1 2! ->    }T
1320 T{    2v1 2@ -> 0. }T
1321 T{ -1 -2 2v1 2! ->       }T
1322 T{       2v1 2@ -> -1 -2 }T
1323 T{ : cd2 2VARIABLE ; -> }T
1324 T{ cd2 2v2 -> }T
1325 T{ : cd3 2v2 2! ; -> }T
1326 T{ -2 -1 cd3 -> }T
1327 T{ 2v2 2@ -> -2 -1 }T
1328
1329 T{ 2VARIABLE 2v3 IMMEDIATE 5 6 2v3 2! -> }T
1330 T{ 2v3 2@ -> 5 6 }T
1331
1332 \ 2LITERAL
1333 T{ : cd1 [ MAX-2INT ] 2LITERAL ; -> }T
1334 T{ cd1 -> MAX-2INT }T
1335 T{ 2VARIABLE 2v4 IMMEDIATE 5 6 2v4 2! -> }T
1336 T{ : cd7 2v4 [ 2@ ] 2LITERAL ; cd7 -> 5 6 }T
1337 T{ : cd8 [ 6 7 ] 2v4 [ 2! ] ; 2v4 2@ -> 6 7 }T
1338
1339 \ 2VALUE
1340 T{ 1 2 2VALUE t2val -> }T
1341 T{ t2val -> 1 2 }T
1342 T{ 3 4 TO t2val -> }T
1343 T{ t2val -> 3 4 }T
1344 : sett2val t2val 2SWAP TO t2val ;
1345 T{ 5 6 sett2val t2val -> 3 4 5 6 }T
1346
1347 \ D+
1348 T{  0.  5. D+ ->  5. }T                         \ small integers
1349 T{ -5.  0. D+ -> -5. }T
1350 T{  1.  2. D+ ->  3. }T
1351 T{  1. -2. D+ -> -1. }T
1352 T{ -1.  2. D+ ->  1. }T
1353 T{ -1. -2. D+ -> -3. }T
1354 T{ -1.  1. D+ ->  0. }T
1355 T{  0  0  0  5 D+ ->  0  5 }T                  \ mid range integers
1356 T{ -1  5  0  0 D+ -> -1  5 }T
1357 T{  0  0  0 -5 D+ ->  0 -5 }T
1358 T{  0 -5 -1  0 D+ -> -1 -5 }T
1359 T{  0  1  0  2 D+ ->  0  3 }T
1360 T{ -1  1  0 -2 D+ -> -1 -1 }T
1361 T{  0 -1  0  2 D+ ->  0  1 }T
1362 T{  0 -1 -1 -2 D+ -> -1 -3 }T
1363 T{ -1 -1  0  1 D+ -> -1  0 }T
1364
1365 T{ MIN-INT 0 2DUP D+ -> 0 1 }T
1366 T{ MIN-INT S>D MIN-INT 0 D+ -> 0 0 }T
1367
1368 T{  HI-2INT       1. D+ -> 0 HI-INT 1+ }T    \ large double integers
1369 T{  HI-2INT     2DUP D+ -> 1S 1- MAX-INT }T
1370 T{ MAX-2INT MIN-2INT D+ -> -1. }T
1371 T{ MAX-2INT  LO-2INT D+ -> HI-2INT }T
1372 T{  LO-2INT     2DUP D+ -> MIN-2INT }T
1373 T{  HI-2INT MIN-2INT D+ 1. D+ -> LO-2INT }T
1374
1375 \ D-
1376 T{  0.  5. D- -> -5. }T              \ small integers
1377 T{  5.  0. D- ->  5. }T
1378 T{  0. -5. D- ->  5. }T
1379 T{  1.  2. D- -> -1. }T
1380 T{  1. -2. D- ->  3. }T
1381 T{ -1.  2. D- -> -3. }T
1382 T{ -1. -2. D- ->  1. }T
1383 T{ -1. -1. D- ->  0. }T
1384 T{  0  0  0  5 D- ->  0 -5 }T       \ mid-range integers
1385 T{ -1  5  0  0 D- -> -1  5 }T
1386 T{  0  0 -1 -5 D- ->  1  4 }T
1387 T{  0 -5  0  0 D- ->  0 -5 }T
1388 T{ -1  1  0  2 D- -> -1 -1 }T
1389 T{  0  1 -1 -2 D- ->  1  2 }T
1390 T{  0 -1  0  2 D- ->  0 -3 }T
1391 T{  0 -1  0 -2 D- ->  0  1 }T
1392 T{  0  0  0  1 D- ->  0 -1 }T
1393 T{ MIN-INT 0 2DUP D- -> 0. }T
1394 T{ MIN-INT S>D MAX-INT 0 D- -> 1 1S }T
1395 T{ MAX-2INT max-2INT D- -> 0. }T    \ large integers
1396 T{ MIN-2INT min-2INT D- -> 0. }T
1397 T{ MAX-2INT  hi-2INT D- -> lo-2INT DNEGATE }T
1398 T{  HI-2INT  lo-2INT D- -> max-2INT }T
1399 T{  LO-2INT  hi-2INT D- -> min-2INT 1. D+ }T
1400 T{ MIN-2INT min-2INT D- -> 0. }T
1401 T{ MIN-2INT  lo-2INT D- -> lo-2INT }T
1402
1403 \ D0<
1404 T{                0. D0< -> <FALSE> }T
1405 T{                1. D0< -> <FALSE> }T
1406 T{  MIN-INT        0 D0< -> <FALSE> }T
1407 T{        0  MAX-INT D0< -> <FALSE> }T
1408 T{          MAX-2INT D0< -> <FALSE> }T
1409 T{               -1. D0< -> <TRUE>  }T
1410 T{          MIN-2INT D0< -> <TRUE>  }T
1411
1412 \ D0=
1413 T{               1. D0= -> <FALSE> }T
1414 T{ MIN-INT        0 D0= -> <FALSE> }T
1415 T{         MAX-2INT D0= -> <FALSE> }T
1416 T{      -1  MAX-INT D0= -> <FALSE> }T
1417 T{               0. D0= -> <TRUE>  }T
1418 T{              -1. D0= -> <FALSE> }T
1419 T{       0  MIN-INT D0= -> <FALSE> }T
1420
1421 \ D2*
1422 T{              0. D2* -> 0. D2* }T
1423 T{ MIN-INT       0 D2* -> 0 1 }T
1424 T{         HI-2INT D2* -> MAX-2INT 1. D- }T
1425 T{         LO-2INT D2* -> MIN-2INT }T
1426
1427 \ D2/
1428 T{       0. D2/ -> 0.        }T
1429 T{       1. D2/ -> 0.        }T
1430 T{      0 1 D2/ -> MIN-INT 0 }T
1431 T{ MAX-2INT D2/ -> HI-2INT   }T
1432 T{      -1. D2/ -> -1.       }T
1433 T{ MIN-2INT D2/ -> LO-2INT   }T
1434
1435 \ D<
1436 T{       0.       1. D< -> <TRUE>  }T
1437 T{       0.       0. D< -> <FALSE> }T
1438 T{       1.       0. D< -> <FALSE> }T
1439 T{      -1.       1. D< -> <TRUE>  }T
1440 T{      -1.       0. D< -> <TRUE>  }T
1441 T{      -2.      -1. D< -> <TRUE>  }T
1442 T{      -1.      -2. D< -> <FALSE> }T
1443 T{      -1. MAX-2INT D< -> <TRUE>  }T
1444 T{ MIN-2INT MAX-2INT D< -> <TRUE>  }T
1445 T{ MAX-2INT      -1. D< -> <FALSE> }T
1446 T{ MAX-2INT MIN-2INT D< -> <FALSE> }T
1447 T{ MAX-2INT 2DUP -1. D+ D< -> <FALSE> }T
1448 T{ MIN-2INT 2DUP  1. D+ D< -> <TRUE>  }T
1449
1450 \ D=
1451 T{      -1.      -1. D= -> <TRUE>  }T
1452 T{      -1.       0. D= -> <FALSE> }T
1453 T{      -1.       1. D= -> <FALSE> }T
1454 T{       0.      -1. D= -> <FALSE> }T
1455 T{       0.       0. D= -> <TRUE>  }T
1456 T{       0.       1. D= -> <FALSE> }T
1457 T{       1.      -1. D= -> <FALSE> }T
1458 T{       1.       0. D= -> <FALSE> }T
1459 T{       1.       1. D= -> <TRUE>  }T
1460 T{   0   -1    0  -1 D= -> <TRUE>  }T
1461 T{   0   -1    0   0 D= -> <FALSE> }T
1462 T{   0   -1    0   1 D= -> <FALSE> }T
1463 T{   0    0    0  -1 D= -> <FALSE> }T
1464 T{   0    0    0   0 D= -> <TRUE>  }T
1465 T{   0    0    0   1 D= -> <FALSE> }T
1466 T{   0    1    0  -1 D= -> <FALSE> }T
1467 T{   0    1    0   0 D= -> <FALSE> }T
1468 T{   0    1    0   1 D= -> <TRUE>  }T
1469
1470 T{ MAX-2INT MIN-2INT D= -> <FALSE> }T
1471 T{ MAX-2INT       0. D= -> <FALSE> }T
1472 T{ MAX-2INT MAX-2INT D= -> <TRUE>  }T
1473 T{ MAX-2INT HI-2INT  D= -> <FALSE> }T
1474 T{ MAX-2INT MIN-2INT D= -> <FALSE> }T
1475 T{ MIN-2INT MIN-2INT D= -> <TRUE>  }T
1476 T{ MIN-2INT LO-2INT  D= -> <FALSE> }T
1477 T{ MIN-2INT MAX-2INT D= -> <FALSE> }T
1478
1479 \ D>S
1480 T{    1234  0 D>S ->  1234   }T
1481 T{   -1234 -1 D>S -> -1234   }T
1482 T{ MAX-INT  0 D>S -> MAX-INT }T
1483 T{ MIN-INT -1 D>S -> MIN-INT }T
1484
1485
1486 \ DABS
1487 T{       1. DABS -> 1.       }T
1488 T{      -1. DABS -> 1.       }T
1489 T{ MAX-2INT DABS -> MAX-2INT }T
1490 T{ MIN-2INT 1. D+ DABS -> MAX-2INT }T
1491
1492 \ DMAX
1493 T{       1.       2. DMAX ->  2.      }T
1494 T{       1.       0. DMAX ->  1.      }T
1495 T{       1.      -1. DMAX ->  1.      }T
1496 T{       1.       1. DMAX ->  1.      }T
1497 T{       0.       1. DMAX ->  1.      }T
1498 T{       0.      -1. DMAX ->  0.      }T
1499 T{      -1.       1. DMAX ->  1.      }T
1500 T{      -1.      -2. DMAX -> -1.      }T
1501 T{ MAX-2INT  HI-2INT DMAX -> MAX-2INT }T
1502 T{ MAX-2INT MIN-2INT DMAX -> MAX-2INT }T
1503 T{ MIN-2INT MAX-2INT DMAX -> MAX-2INT }T
1504 T{ MIN-2INT  LO-2INT DMAX -> LO-2INT  }T
1505
1506 T{ MAX-2INT       1. DMAX -> MAX-2INT }T
1507 T{ MAX-2INT      -1. DMAX -> MAX-2INT }T
1508 T{ MIN-2INT       1. DMAX ->  1.      }T
1509 T{ MIN-2INT      -1. DMAX -> -1.      }T
1510
1511 \ DMIN
1512 T{       1.       2. DMIN ->  1.      }T
1513 T{       1.       0. DMIN ->  0.      }T
1514 T{       1.      -1. DMIN -> -1.      }T
1515 T{       1.       1. DMIN ->  1.      }T
1516 T{       0.       1. DMIN ->  0.      }T
1517 T{       0.      -1. DMIN -> -1.      }T
1518 T{      -1.       1. DMIN -> -1.      }T
1519 T{      -1.      -2. DMIN -> -2.      }T
1520 T{ MAX-2INT  HI-2INT DMIN -> HI-2INT  }T
1521 T{ MAX-2INT MIN-2INT DMIN -> MIN-2INT }T
1522 T{ MIN-2INT MAX-2INT DMIN -> MIN-2INT }T
1523 T{ MIN-2INT  LO-2INT DMIN -> MIN-2INT }T
1524
1525 T{ MAX-2INT       1. DMIN ->  1.      }T
1526 T{ MAX-2INT      -1. DMIN -> -1.      }T
1527 T{ MIN-2INT       1. DMIN -> MIN-2INT }T
1528 T{ MIN-2INT      -1. DMIN -> MIN-2INT }T
1529
1530 \ DNEGATE
1531 T{   0. DNEGATE ->  0. }T
1532 T{   1. DNEGATE -> -1. }T
1533 T{  -1. DNEGATE ->  1. }T
1534 T{ max-2int DNEGATE -> min-2int SWAP 1+ SWAP }T
1535 T{ min-2int SWAP 1+ SWAP DNEGATE -> max-2int }T
1536
1537 \ 2ROT
1538 T{       1.       2. 3. 2ROT ->       2. 3.       1. }T
1539 T{ MAX-2INT MIN-2INT 1. 2ROT -> MIN-2INT 1. MAX-2INT }T
1540
1541 \ DU<
1542 T{       1.       1. DU< -> <FALSE> }T
1543 T{       1.      -1. DU< -> <TRUE>  }T
1544 T{      -1.       1. DU< -> <FALSE> }T
1545 T{      -1.      -2. DU< -> <FALSE> }T
1546 T{ MAX-2INT  HI-2INT DU< -> <FALSE> }T
1547 T{  HI-2INT MAX-2INT DU< -> <TRUE>  }T
1548 T{ MAX-2INT MIN-2INT DU< -> <TRUE>  }T
1549 T{ MIN-2INT MAX-2INT DU< -> <FALSE> }T
1550 T{ MIN-2INT  LO-2INT DU< -> <TRUE>  }T
1551
1552 \ M+
1553 T{ HI-2INT   1 M+ -> HI-2INT   1. D+ }T
1554 T{ MAX-2INT -1 M+ -> MAX-2INT -1. D+ }T
1555 T{ MIN-2INT  1 M+ -> MIN-2INT  1. D+ }T
1556 T{ LO-2INT  -1 M+ -> LO-2INT  -1. D+ }T
1557
1558 \ M*/
1559 : ?floored [ -3 2 / -2 = ] LITERAL IF 1. D- THEN ;
1560
1561 T{       5.       7             11 M*/ ->  3. }T
1562 T{       5.      -7             11 M*/ -> -3. ?floored }T
1563 T{      -5.       7             11 M*/ -> -3. ?floored }T
1564 T{      -5.      -7             11 M*/ ->  3. }T
1565
1566 T{ MAX-2INT       8             16 M*/ -> HI-2INT }T
1567 T{ MAX-2INT      -8             16 M*/ -> HI-2INT DNEGATE ?floored }T
1568 T{ MIN-2INT       8             16 M*/ -> LO-2INT }T
1569 T{ MIN-2INT      -8             16 M*/ -> LO-2INT DNEGATE }T
1570
1571 T{ MAX-2INT MAX-INT        MAX-INT M*/ -> MAX-2INT }T
1572 T{ MAX-2INT MAX-INT 2/     MAX-INT M*/ -> MAX-INT 1- HI-2INT NIP }T
1573 T{ MIN-2INT LO-2INT NIP DUP NEGATE M*/ -> MIN-2INT }T
1574 T{ MIN-2INT LO-2INT NIP 1- MAX-INT M*/ -> MIN-INT 3 + HI-2INT NIP 2 + }T
1575 T{ MAX-2INT LO-2INT NIP DUP NEGATE M*/ -> MAX-2INT DNEGATE }T
1576 T{ MIN-2INT MAX-INT            DUP M*/ -> MIN-2INT }T
1577
1578 \ D.R
1579 MAX-2INT 71 73 M*/ 2CONSTANT dbl1
1580 MIN-2INT 73 79 M*/ 2CONSTANT dbl2
1581 : d>ascii \ ( d -- caddr u )
1582    DUP >R <# DABS #S R> SIGN #>  \  ( -- caddr1 u )
1583    HERE SWAP 2DUP 2>R CHARS DUP ALLOT MOVE 2R>
1584 ;
1585
1586 dbl1 d>ascii 2CONSTANT "dbl1"
1587 dbl2 d>ascii 2CONSTANT "dbl2"
1588
1589 : DoubleOutput
1590    CR ." You should see lines duplicated:" CR
1591    5 SPACES "dbl1" TYPE CR
1592    5 SPACES dbl1 D. CR
1593    8 SPACES "dbl1" DUP >R TYPE CR
1594    5 SPACES dbl1 R> 3 + D.R CR
1595    5 SPACES "dbl2" TYPE CR
1596    5 SPACES dbl2 D. CR
1597    10 SPACES "dbl2" DUP >R TYPE CR
1598    5 SPACES dbl2 R> 5 + D.R CR
1599 ;
1600
1601 T{ DoubleOutput -> }T
1602
1603 RST_STATE