ADDON/DOUBLE.asm

   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 ; -----------------------------------------------------
  32 ; DOUBLE.asm
  33 ; -----------------------------------------------------
  34
  35     FORTHWORD "{DOUBLE}"
  36             MOV @IP+,PC
  37
  38     .IFNDEF TOR
  39 ; https://forth-standard.org/standard/core/toR
  40 ; >R    x --   R: -- x   push to return stack
  41             FORTHWORD ">R"
  42 TOR         PUSH TOS
  43             MOV @PSP+,TOS
  44             MOV @IP+,PC
  45
  46         .ENDIF
  47         .IFNDEF RFROM1
  48 ; https://forth-standard.org/standard/core/Rfrom
  49 ; R>    -- x    R: x --   pop from return stack
  50             FORTHWORD "R>"
  51 RFROM1      SUB #2,PSP      ; 1
  52             MOV TOS,0(PSP)  ; 3
  53             MOV @RSP+,TOS   ; 2
  54             MOV @IP+,PC     ; 4
  55
  56         .ENDIF
  57         .IFNDEF ZEROLESS
  58             FORTHWORD "0<"
  59 ; https://forth-standard.org/standard/core/Zeroless
  60 ; 0<     n -- flag      true if TOS negative
  61 ZEROLESS    ADD TOS,TOS     ;1 set carry if TOS negative
  62             SUBC TOS,TOS    ;1 TOS=-1 if carry was clear
  63 EQUALTRUE   XOR #-1,TOS     ;1 TOS=-1 if carry was set
  64             MOV @IP+,PC     ;
  65
  66         .ENDIF
  67         .IFNDEF STOD
  68 ; https://forth-standard.org/standard/core/StoD
  69 ; S>D    n -- d          single -> double prec.
  70             FORTHWORD "S>D"
  71 STOD        SUB #2,PSP
  72             MOV TOS,0(PSP)
  73             MOV #ZEROLESS,PC
  74
  75         .ENDIF
  76         .IFNDEF DROP1
  77 ; https://forth-standard.org/standard/core/DROP
  78 ; DROP     x --          drop top of stack
  79             FORTHWORD "DROP"
  80 DROP1       MOV @PSP+,TOS   ; 2
  81             MOV @IP+,PC     ; 4
  82
  83         .ENDIF
  84         .IFNDEF QDUP
  85 ; https://forth-standard.org/standard/core/DUP
  86 ; DUP      x -- x x      duplicate top of stack
  87             FORTHWORD "DUP"
  88 QDUPNEXT    SUB #2,PSP      ; 2  push old TOS..
  89             MOV TOS,0(PSP)  ; 3  ..onto stack
  90 QDUPEND     MOV @IP+,PC     ; 4
  91
  92 ; https://forth-standard.org/standard/core/qDUP
  93 ; ?DUP     x -- 0 | x x    DUP if nonzero
  94             FORTHWORD "?DUP"
  95 QDUP        CMP #0,TOS
  96             JNZ QDUPNEXT
  97             JZ QDUPEND
  98
  99         .ENDIF
 100         .IFNDEF SWAP
 101 ; https://forth-standard.org/standard/core/SWAP
 102 ; SWAP     x1 x2 -- x2 x1    swap top two items
 103             FORTHWORD "SWAP"
 104 SWAP        MOV @PSP,W      ; 2
 105             MOV TOS,0(PSP)  ; 3
 106             MOV W,TOS       ; 1
 107             MOV @IP+,PC     ; 4
 108
 109         .ENDIF
 110         .IFNDEF OVER
 111 ;https://forth-standard.org/standard/core/OVER
 112 ;C OVER    x1 x2 -- x1 x2 x1
 113             FORTHWORD "OVER"
 114 OVER        MOV TOS,-2(PSP)     ; 3 -- x1 (x2) x2
 115             MOV @PSP,TOS        ; 2 -- x1 (x2) x1
 116             SUB #2,PSP          ; 1 -- x1 x2 x1
 117             MOV @IP+,PC               ; 4
 118
 119         .ENDIF
 120         .IFNDEF NIP1
 121             FORTHWORD "NIP"
 122 ; https://forth-standard.org/standard/core/NIP
 123 ; NIP      x1 x2 -- x2         Drop the first item below the top of stack
 124 NIP1        ADD #2,PSP      ; 1
 125             MOV @IP+,PC     ; 4
 126
 127         .ENDIF
 128         .IFNDEF ROT
 129 ;https://forth-standard.org/standard/core/ROT
 130 ;C ROT    x1 x2 x3 -- x2 x3 x1
 131             FORTHWORD "ROT"
 132 ROT         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     ; 4
 137
 138         .ENDIF
 139         .IFNDEF UMSLASHMOD
 140 ;https://forth-standard.org/standard/core/UMDivMOD
 141 ; UM/MOD   udlo|udhi u1 -- r q   unsigned 32/16->r16 q16
 142             FORTHWORD "UM/MOD"
 143 UMSLASHMOD  PUSH #DROP          ;3 as return address for MU/MOD
 144             MOV #MUSMOD,PC
 145
 146         .ENDIF
 147         .IFNDEF FLOORED_DIVISION
 148             .IFNDEF SMSLASHREM
 149 ;https://forth-standard.org/standard/core/SMDivREM
 150 ;C SM/REM   d1lo d1hi n2 -- n3 n4  symmetric signed div
 151             FORTHWORD "SM/REM"
 152 SMSLASHREM  MOV TOS,S           ;1            S=divisor
 153             MOV @PSP,T          ;2            T=rem_sign
 154             CMP #0,TOS          ;1            n2 >= 0 ?
 155             JGE d1u2SMSLASHREM  ;2            yes
 156             XOR #-1,TOS         ;1
 157             ADD #1,TOS          ;1
 158 d1u2SMSLASHREM                  ;   -- d1 u2
 159             CMP #0,0(PSP)       ;3           d1hi >= 0 ?
 160             JGE ud1u2SMSLASHREM ;2           yes
 161             XOR #-1,2(PSP)      ;4           d1lo
 162             XOR #-1,0(PSP)      ;4           d1hi
 163             ADD #1,2(PSP)       ;4           d1lo+1
 164             ADDC #0,0(PSP)      ;4           d1hi+C
 165 ud1u2SMSLASHREM                 ;   -- ud1 u2
 166             PUSHM  #2,S          ;4         PUSHM S,T
 167             CALL #MUSMOD
 168             MOV @PSP+,TOS
 169             POPM  #2,S          ;4          POPM T,S
 170             CMP #0,T            ;1  -- ur uq  T=rem_sign>=0?
 171             JGE SMSLASHREMnruq  ;2           yes
 172             XOR #-1,0(PSP)      ;3
 173             ADD #1,0(PSP)       ;3
 174 SMSLASHREMnruq
 175             XOR S,T             ;1           S=divisor T=quot_sign
 176             CMP #0,T            ;1  -- nr uq  T=quot_sign>=0?
 177             JGE SMSLASHREMnrnq  ;2           yes
 178 NEGAT       XOR #-1,TOS         ;1
 179             ADD #1,TOS          ;1
 180 SMSLASHREMnrnq                  ;   -- nr nq  S=divisor
 181             MOV @IP+,PC         ;4 34 words
 182
 183             .ENDIF
 184         .ELSE   ; FLOORED_DIVISION
 185             .IFNDEF FMSLASHMOD
 186 ;https://forth-standard.org/standard/core/FMDivMOD
 187 ;C FM/MOD   d1 n1 -- r q   floored signed div'n
 188             FORTHWORD "FM/MOD"
 189 FMSLASHMOD  MOV TOS,S           ;1            S=divisor
 190             MOV @PSP,T          ;2            T=rem_sign
 191             CMP #0,TOS          ;1            n2 >= 0 ?
 192             JGE d1u2FMSLASHMOD  ;2            yes
 193             XOR #-1,TOS         ;1
 194             ADD #1,TOS          ;1
 195 d1u2FMSLASHMOD                  ;   -- d1 u2
 196             CMP #0,0(PSP)       ;3           d1hi >= 0 ?
 197             JGE ud1u2FMSLASHMOD ;2           yes
 198             XOR #-1,2(PSP)      ;4           d1lo
 199             XOR #-1,0(PSP)      ;4           d1hi
 200             ADD #1,2(PSP)       ;4           d1lo+1
 201             ADDC #0,0(PSP)      ;4           d1hi+C
 202 ud1u2FMSLASHMOD                 ;   -- ud1 u2
 203             PUSHM  #2,S          ;4         PUSHM S,T
 204             CALL #MUSMOD
 205             MOV @PSP+,TOS
 206             POPM  #2,S          ;4          POPM T,S
 207             CMP #0,T            ;1  -- ur uq  T=rem_sign>=0?
 208             JGE FMSLASHMODnruq  ;2           yes
 209             XOR #-1,0(PSP)      ;3
 210             ADD #1,0(PSP)       ;3
 211 FMSLASHMODnruq
 212             XOR S,T             ;1           S=divisor T=quot_sign
 213             CMP #0,T            ;1  -- nr uq  T=quot_sign>=0?
 214             JGE FMSLASHMODnrnq  ;2           yes
 215 NEGAT       XOR #-1,TOS         ;1
 216             ADD #1,TOS          ;1
 217 FMSLASHMODnrnq                  ;   -- nr nq  S=divisor
 218
 219             CMP #0,0(PSP)       ;
 220             JZ FMSLASHMODEND
 221             CMP #1,TOS          ; quotient < 1 ?
 222             JGE FMSLASHMODEND   ;
 223 QUOTLESSONE ADD S,0(PSP)        ; add divisor to remainder
 224             SUB #1,TOS          ; decrement quotient
 225 FMSLASHMODEND
 226             MOV @RSP+,IP
 227             MOV @IP+,PC         ;
 228
 229             .ENDIF
 230         .ENDIF
 231         .IFNDEF SLASH
 232 ;https://forth-standard.org/standard/core/Div
 233 ;C /      n1 n2 -- n3       signed divide
 234             FORTHWORD "/"
 235 SLASH       mDOCOL
 236             .word   TOR,STOD,RFROM
 237             .IFNDEF FLOORED_DIVISION
 238             .word SMSLASHREM
 239             .ELSE
 240             .word FMSLASHMOD
 241             .ENDIF
 242             .word NIP,EXIT
 243
 244         .ENDIF
 245         .IFNDEF CFETCH
 246 ;https://forth-standard.org/standard/core/CFetch
 247 ; C@     c-addr -- char   fetch char from memory
 248             FORTHWORD "C@"
 249 CFETCH      MOV.B @TOS,TOS      ;2
 250             MOV @IP+,PC         ;4
 251
 252         .ENDIF
 253         .IFNDEF LESS
 254 ; https://forth-standard.org/standard/core/OneMinus
 255 ; 1-      n1/u1 -- n2/u2     subtract 1 from TOS
 256             FORTHWORD "1-"
 257 ONEMINUS1   SUB #1,TOS
 258             MOV @IP+,PC
 259
 260         .ENDIF
 261         .IFNDEF LESS
 262 ;https://forth-standard.org/standard/core/less
 263 ;C <      n1 n2 -- flag        test n1<n2, signed
 264             FORTHWORD "<"
 265 LESS        SUB @PSP+,TOS   ;1 TOS=n2-n1
 266             JZ LESSEND      ;2 flag Z = 1
 267             JL TOSFALSE     ;2 signed jump
 268 TOSTRUE     MOV #-1,TOS     ;1 flag Z = 0
 269 LESSEND     MOV @IP+,PC     ;4
 270
 271 ;https://forth-standard.org/standard/core/more
 272 ;C >     n1 n2 -- flag         test n1>n2, signed
 273             FORTHWORD ">"
 274 MORE        SUB @PSP+,TOS   ;2 TOS=n2-n1
 275             JL TOSTRUE      ;2 --> +5
 276 TOSFALSE    AND #0,TOS      ;1 flag Z = 1
 277             MOV @IP+,PC     ;4
 278
 279         .ENDIF
 280
 281 ;    .IFNDEF IFF
 282 ;; https://forth-standard.org/standard/core/IF
 283 ;; IF       -- IFadr    initialize conditional forward branch
 284 ;            FORTHWORDIMM "IF"       ; immediate
 285 ;IFF         SUB #2,PSP              ;
 286 ;            MOV TOS,0(PSP)          ;
 287 ;            MOV &DP,TOS            ; -- HERE
 288 ;            ADD #4,&DP             ;           compile one word, reserve one word
 289 ;            MOV #QFBRAN,0(TOS)      ; -- HERE   compile QFBRAN
 290 ;            ADD #2,TOS              ; -- HERE+2=IFadr
 291 ;            MOV @IP+,PC
 292 ;
 293 ;            FORTHWORDIMM "ELSE"     ; immediate
 294 ;; https://forth-standard.org/standard/core/ELSE
 295 ;; ELSE     IFadr -- ELSEadr        resolve forward IF branch, leave ELSEadr on stack
 296 ;ELSS        ADD #4,&DP             ; make room to compile two words
 297 ;            MOV &DP,W              ; W=HERE+4
 298 ;            MOV #BRAN,-4(W)
 299 ;            MOV W,0(TOS)            ; HERE+4 ==> [IFadr]
 300 ;            SUB #2,W                ; HERE+2
 301 ;            MOV W,TOS               ; -- ELSEadr
 302 ;            MOV @IP+,PC
 303 ;
 304 ;            FORTHWORDIMM "THEN"     ; immediate
 305 ;; https://forth-standard.org/standard/core/THEN
 306 ;; THEN     IFadr --                resolve forward branch
 307 ;THEN        MOV &DP,0(TOS)         ; -- IFadr
 308 ;            MOV @PSP+,TOS           ; --
 309 ;            MOV @IP+,PC
 310 ;    .ENDIF
 311
 312     .IFNDEF TO
 313 ; https://forth-standard.org/standard/core/TO
 314             FORTHWORD "TO"
 315 TO          BIS #UF9,SR
 316             MOV @IP+,PC
 317
 318     .ENDIF
 319     .IFNDEF SPACE
 320 ;https://forth-standard.org/standard/core/SPACE
 321 ;C SPACE   --               output a space
 322             FORTHWORD "SPACE"
 323 SPACE       SUB #2,PSP              ;1
 324             MOV TOS,0(PSP)          ;3
 325             MOV #20h,TOS            ;2
 326             MOV #EMIT,PC            ;17~  23~
 327
 328     .ENDIF
 329     .IFNDEF SPACES
 330 ;https://forth-standard.org/standard/core/SPACES
 331 ;C SPACES   n --            output n spaces
 332             FORTHWORD "SPACES"
 333 SPACES      CMP #0,TOS
 334             JZ SPACESNEXT2
 335             PUSH IP
 336             MOV #SPACESNEXT,IP
 337             JMP SPACE               ;25~
 338 SPACESNEXT  mNEXTADR
 339             SUB #2,IP               ;1
 340             SUB #1,TOS              ;1
 341             JNZ SPACE               ;25~ ==> 27~ by space ==> 2.963 MBds @ 8 MHz
 342             MOV @RSP+,IP            ;
 343 SPACESNEXT2 MOV @PSP+,TOS           ; --         drop n
 344             MOV @IP+,PC             ;
 345
 346     .ENDIF
 347     .IFNDEF TWOFETCH
 348 ; https://forth-standard.org/standard/core/TwoFetch
 349 ; 2@    a-addr -- x1 x2    fetch 2 cells ; the lower address will appear on top of stack
 350             FORTHWORD "2@"
 351 TWOFETCH    SUB #2, PSP
 352             MOV 2(TOS),0(PSP)
 353             MOV @TOS,TOS
 354             MOV @IP+,PC
 355
 356     .ENDIF
 357     .IFNDEF TWOSTORE
 358 ; https://forth-standard.org/standard/core/TwoStore
 359 ; 2!    x1 x2 a-addr --    store 2 cells ; the top of stack is stored at the lower adr
 360             FORTHWORD "2!"
 361 TWOSTORE    MOV @PSP+,0(TOS)
 362             MOV @PSP+,2(TOS)
 363             MOV @PSP+,TOS
 364             MOV @IP+,PC
 365
 366     .ENDIF
 367     .IFNDEF TWODUP
 368 ; https://forth-standard.org/standard/core/TwoDUP
 369 ; 2DUP   x1 x2 -- x1 x2 x1 x2   dup top 2 cells
 370             FORTHWORD "2DUP"
 371 TWODUP      MOV TOS,-2(PSP)     ; 3
 372             MOV @PSP,-4(PSP)    ; 4
 373             SUB #4,PSP          ; 1
 374             MOV @IP+,PC         ; 4
 375
 376     .ENDIF
 377     .IFNDEF TWODROP
 378 ; https://forth-standard.org/standard/core/TwoDROP
 379 ; 2DROP  x1 x2 --          drop 2 cells
 380             FORTHWORD "2DROP"
 381 TWODROP     ADD #2,PSP
 382             MOV @PSP+,TOS
 383             MOV @IP+,PC
 384
 385    .ENDIF
 386     .IFNDEF TWOSWAP
 387 ; https://forth-standard.org/standard/core/TwoSWAP
 388 ; 2SWAP  x1 x2 x3 x4 -- x3 x4 x1 x2
 389             FORTHWORD "2SWAP"
 390 TWOSWAP     MOV @PSP,W          ; -- x1 x2 x3 x4    W=x3
 391             MOV 4(PSP),0(PSP)   ; -- x1 x2 x1 x4
 392             MOV W,4(PSP)        ; -- x3 x2 x1 x4
 393             MOV TOS,W           ; -- x3 x2 x1 x4    W=x4
 394             MOV 2(PSP),TOS      ; -- x3 x2 x1 x2    W=x4
 395             MOV W,2(PSP)        ; -- x3 x4 x1 x2
 396             MOV @IP+,PC
 397
 398     .ENDIF
 399     .IFNDEF TwoOVER
 400 ; https://forth-standard.org/standard/core/TwoOVER
 401 ; 2OVER  x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2
 402             FORTHWORD "2OVER"
 403 TwoOVER     SUB #4,PSP          ; -- x1 x2 x3 x x x4
 404             MOV TOS,2(PSP)      ; -- x1 x2 x3 x4 x x4
 405             MOV 8(PSP),0(PSP)   ; -- x1 x2 x3 x4 x1 x4
 406             MOV 6(PSP),TOS      ; -- x1 x2 x3 x4 x1 x2
 407             MOV @IP+,PC
 408
 409     .ENDIF
 410     .IFNDEF TWOTOR
 411 ; https://forth-standard.org/standard/core/TwotoR
 412 ; ( x1 x2 -- ) ( R: -- x1 x2 )   Transfer cell pair x1 x2 to the return stack.
 413             FORTHWORD "2>R"
 414 TWOTOR      PUSH @PSP+
 415             PUSH TOS
 416             MOV @PSP+,TOS
 417             MOV @IP+,PC
 418
 419     .ENDIF
 420     .IFNDEF TWORFETCH
 421 ; https://forth-standard.org/standard/core/TwoRFetch
 422 ; ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) Copy cell pair x1 x2 from the return stack.
 423             FORTHWORD "2R@"
 424 TWORFETCH   SUB #4,PSP
 425             MOV TOS,2(PSP)
 426             MOV @RSP,TOS
 427             MOV 2(RSP),0(PSP)
 428             MOV @IP+,PC
 429
 430     .ENDIF
 431     .IFNDEF TwoRfrom
 432 ; https://forth-standard.org/standard/core/TwoRfrom
 433 ; ( -- x1 x2 ) ( R: x1 x2 -- )  Transfer cell pair x1 x2 from the return stack
 434             FORTHWORD "2R>"
 435 TWORFROM    SUB #4,PSP
 436             MOV TOS,2(PSP)
 437             MOV @RSP+,TOS
 438             MOV @RSP+,0(PSP)
 439             MOV @IP+,PC
 440     .ENDIF
 441
 442 ; ===============================================
 443 ; DOUBLE word set
 444 ; ===============================================
 445     .IFNDEF DDOT
 446 ; https://forth-standard.org/standard/double/Dd
 447 ; D.     dlo dhi --           display d (signed)
 448             FORTHWORD "D."
 449             MOV TOS,S       ; S will be pushed as sign
 450             MOV #UDOT+10,PC   ; U. + 10 = D.
 451
 452     .ENDIF
 453     .IFNDEF TwoROT
 454 ; https://forth-standard.org/standard/double/TwoROT
 455 ; Rotate the top three cell pairs on the stack bringing cell pair x1 x2 to the top of the stack.
 456             FORTHWORD "2ROT"
 457 TWOROT      MOV 8(PSP),X        ; 3
 458             MOV 6(PSP),Y        ; 3
 459             MOV 4(PSP),8(PSP)   ; 5
 460             MOV 2(PSP),6(PSP)   ; 5
 461             MOV @PSP,4(PSP)     ; 4
 462             MOV TOS,2(PSP)      ; 3
 463             MOV X,0(PSP)        ; 3
 464             MOV Y,TOS           ; 1
 465             MOV @IP+,PC
 466
 467     .ENDIF
 468     .IFNDEF DtoS
 469 ; https://forth-standard.org/standard/double/DtoS
 470 ; D>S    d -- n          double prec -> single.
 471             FORTHWORD "D>S"
 472 DTOS        MOV @PSP+,TOS
 473             MOV @IP+,PC
 474
 475     .ENDIF
 476     .IFNDEF DZEQU
 477 ; https://forth-standard.org/standard/double/DZeroEqual
 478             FORTHWORD "D0="
 479 DZEROEQUAL  ADD #2,PSP
 480             CMP #0,TOS
 481             MOV #0,TOS
 482             JNZ DSETFLAG
 483             CMP #0,-2(PSP)
 484             JNZ DSETFLAG
 485 DTRUE       MOV #-1,TOS
 486 DSETFLAG    AND #-1,TOS         ;  to set N, Z flags
 487             MOV @IP+,PC
 488
 489 ; https://forth-standard.org/standard/double/DZeroless
 490             FORTHWORD "D0<"
 491 DZEROLESS   ADD #2,PSP
 492             CMP #0,TOS
 493             MOV #0,TOS
 494             JGE DSETFLAG
 495             JL DTRUE
 496
 497 ; https://forth-standard.org/standard/double/DEqual
 498             FORTHWORD "D="
 499 DEQUAL      ADD #6,PSP          ; 2
 500             CMP TOS,-4(PSP)     ; 3 ud1H - ud2H
 501             MOV #0,TOS          ; 1
 502             JNZ DSETFLAG        ; 2
 503             CMP -6(PSP),-2(PSP) ; 4 ud1L - ud2L
 504             JZ DTRUE            ; 2
 505             JMP DSETFLAG
 506
 507 ; https://forth-standard.org/standard/double/Dless
 508 ; flag is true if and only if d1 is less than d2
 509             FORTHWORD "D<"
 510 DLESS       ADD #6,PSP          ; 2
 511             CMP TOS,-4(PSP)     ; 3 d1H - d2H
 512             MOV #0,TOS          ; 1
 513             JGE DLESS2          ; 2
 514 DLESS1      MOV #-1,TOS         ;
 515 DLESS2      JNZ DSETFLAG        ; 2
 516             CMP -6(PSP),-2(PSP) ; 4 d1L - d2L
 517             JNC DTRUE           ; 2
 518             JMP DSETFLAG        ; 2
 519
 520 ; https://forth-standard.org/standard/double/DUless
 521 ; flag is true if and only if ud1 is less than ud2
 522             FORTHWORD "DU<"
 523 DULESS      ADD #6,PSP          ; 2
 524             CMP TOS,-4(PSP)     ; 3 ud1H - ud2H
 525             MOV #0,TOS          ; 1
 526             JC DLESS2           ; 2
 527             JNC DLESS1
 528
 529     .ENDIF ; DZEQU
 530     .IFNDEF DPlus
 531 ; https://forth-standard.org/standard/double/DPlus
 532             FORTHWORD "D+"
 533 DPLUS       ADD @PSP+,2(PSP)
 534             ADDC @PSP+,TOS
 535             MOV @IP+,PC         ; 4
 536
 537     .ENDIF
 538     .IFNDEF MPLUS
 539 ; https://forth-standard.org/standard/double/MPlus
 540             FORTHWORD "M+"
 541 MPLUS       SUB #2,PSP
 542             CMP #0,TOS
 543             MOV TOS,0(PSP)
 544             MOV #-1,TOS
 545             JL DPLUS
 546             MOV #0,TOS
 547             JMP DPLUS
 548
 549     .ENDIF
 550     .IFNDEF DMinus
 551 ; https://forth-standard.org/standard/double/DMinus
 552             FORTHWORD "D-"
 553 DMINUS      SUB @PSP+,2(PSP)
 554             SUBC TOS,0(PSP)
 555             MOV @PSP+,TOS
 556             MOV @IP+,PC         ; 4
 557
 558     .ENDIF
 559     .IFNDEF DNEGATE
 560 ; https://forth-standard.org/standard/double/DNEGATE
 561             FORTHWORD "DNEGATE"
 562 DNEGATE     XOR #-1,0(PSP)
 563             XOR #-1,TOS
 564             ADD #1,0(PSP)
 565             ADDC #0,TOS
 566             MOV @IP+,PC         ; 4
 567
 568 ; https://forth-standard.org/standard/double/DABS
 569 ; DABS     d1 -- |d1|     absolute value
 570             FORTHWORD "DABS"
 571 DABS        CMP #0,TOS       ;  1
 572             JL DNEGATE
 573             MOV @IP+,PC
 574
 575     .ENDIF
 576     .IFNDEF DTwoDiv
 577 ; https://forth-standard.org/standard/double/DTwoDiv
 578             FORTHWORD "D2/"
 579 DTWODIV     RRA TOS
 580             RRC 0(PSP)
 581             MOV @IP+,PC         ; 4
 582
 583     .ENDIF
 584     .IFNDEF DTwoTimes
 585 ; https://forth-standard.org/standard/double/DTwoTimes
 586 DTWOTIMES   FORTHWORD "D2*"
 587             ADD @PSP,0(PSP)
 588             ADDC TOS,TOS
 589             MOV @IP+,PC         ; 4
 590
 591     .ENDIF
 592     .IFNDEF DMAX
 593 ; https://forth-standard.org/standard/double/DMAX
 594             FORTHWORD "DMAX"                ; -- d1 d2
 595 DMAX        mDOCOL
 596             .word   TWOOVER,TWOOVER         ; -- d1 d2 d1 d2
 597             .word   DLESS,QFBRAN,DMAX1      ; -- d1 d2
 598             .word   TWOTOR,TWODROP,TWORFROM ; -- d2
 599             .word   BRAN,DMAX2              ; -- d1 d2
 600 DMAX1       .word   TWODROP                 ; -- d1
 601 DMAX2       .word   EXIT
 602
 603     .ENDIF
 604     .IFNDEF DMIN
 605 ; https://forth-standard.org/standard/double/DMIN
 606             FORTHWORD "DMIN"                ; -- d1 d2
 607 DMIN        mDOCOL
 608             .word   TWOOVER,TWOOVER         ; -- d1 d2 d1 d2
 609             .word   DLESS,QFBRAN,DMIN1      ; -- d1 d2
 610             .word   TWODROP                 ; -- d1
 611             .word   BRAN,DMIN2              ; -- d1 d2
 612 DMIN1       .word   TWOTOR,TWODROP,TWORFROM ; -- d2
 613 DMIN2       .word   EXIT
 614
 615     .ENDIF
 616     .IFNDEF MTIMESDIV
 617 ;   https://forth-standard.org/standard/double/MTimesDiv
 618             FORTHWORD "M*/"                ; d1 * n1 / +n2 -- d2
 619 MTIMESDIV
 620         .IFDEF HMPY
 621             MOV 4(PSP),&MPYS32L     ; 5             Load 1st operand    d1lo
 622             MOV 2(PSP),&MPYS32H     ; 5                                 d1hi
 623             MOV @PSP+,&OP2          ; 4 -- d1 n2    load 2nd operand    n1
 624             MOV TOS,T               ; T = DIV
 625             NOP3
 626             MOV &RES0,S             ; 3 S = RESlo
 627             MOV &RES1,TOS           ; 3 TOS = RESmi
 628             MOV &RES2,W             ; 3 W = REShi
 629             MOV #0,rDOCON           ; clear sign flag
 630             CMP #0,W                ; negative product ?
 631             JGE MTIMESDIV1          ; no
 632             XOR #-1,S               ; compute ABS value if yes
 633             XOR #-1,TOS
 634             XOR #-1,W
 635             ADD #1,S
 636             ADDC #0,TOS
 637             ADDC #0,W
 638             MOV #-1,rDOCON          ; set sign flag
 639 MTIMESDIV1
 640         .ELSE
 641             MOV #0,rDOCON           ; rDOCON = sign
 642             CMP #0,2(PSP)           ; d1 < 0 ?
 643             JGE MTIMESDIV2          ; no
 644             XOR #-1,4(PSP)          ; compute ABS value if yes
 645             XOR #-1,2(PSP)
 646             ADD #1,4(PSP)
 647             ADDC #0,2(PSP)
 648             MOV #-1,rDOCON
 649 MTIMESDIV2                          ; ud1
 650             CMP #0,0(PSP)           ; n1 < 0 ?
 651             JGE MTIMESDIV3          ; no
 652             XOR #-1,0(PSP)
 653             ADD #1,0(PSP)           ; u1
 654             XOR #-1,rDOCON
 655 ; let's process UM*     -- ud1lo ud1hi u1 +n2
 656 MTIMESDIV3  MOV 4(PSP),Y            ; 3 uMDlo
 657             MOV 2(PSP),T            ; 3 uMDhi
 658             MOV @PSP+,S             ; 2 uMRlo        -- ud1lo ud1hi +n2
 659             MOV #0,rDODOES          ; 1 uMDlo=0
 660             MOV #0,2(PSP)           ; 3 uRESlo=0
 661             MOV #0,0(PSP)           ; 3 uRESmi=0     -- uRESlo uRESmi +n2
 662             MOV #0,W                ; 1 uREShi=0
 663             MOV #1,X                ; 1 BIT TEST REGlo
 664 MTIMESDIV4  BIT X,S                 ; 1 test actual bit in uMRlo
 665             JZ MTIMESDIV5
 666             ADD Y,2(PSP)            ; 3 IF 1: ADD uMDlo TO uRESlo
 667             ADDC T,0(PSP)           ; 3      ADDC uMDmi TO uRESmi
 668             ADDC rDODOES,W          ; 1      ADDC uMRlo TO uREShi
 669 MTIMESDIV5  ADD Y,Y                 ; 1 (RLA LSBs) uMDlo *2
 670             ADDC T,T                ; 1 (RLC MSBs) uMDhi *2
 671             ADDC rDODOES,rDODOES    ; 1 (RLA LSBs) uMDlo *2
 672             ADD X,X                 ; 1 (RLA) NEXT BIT TO TEST
 673             JNC MTIMESDIV4          ; 1 IF BIT IN CARRY: FINISHED   W=uREShi
 674 ;           TOS     +n2
 675 ;           W       REShi
 676 ;           0(PSP)  RESmi
 677 ;           2(PSP)  RESlo
 678             MOV TOS,T
 679             MOV @PSP,TOS
 680             MOV 2(PSP),S
 681         .ENDIF  ; endcase of software/hardware_MPY
 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 ;           rDOCON  = sign
 693 ;           2(PSP)                  REM
 694 ;           0(PSP)                  QUOTlo
 695 ;           TOS                     QUOThi
 696             MOV #32,rDODOES         ; 2  init loop count
 697             CMP #0,W                ; DVDhi = 0 ?
 698             JNZ MTIMESDIV6          ; if no
 699             MOV TOS,W               ; DVDmi --> DVDhi
 700             CALL #MDIV1DIV2         ; with loop count / 2
 701             JMP MTIMESDIV7
 702 MTIMESDIV6  CALL #MDIV1             ; -- urem ud2lo ud2hi
 703 MTIMESDIV7  MOV @PSP+,0(PSP)        ; -- d2lo d2hi
 704             CMP #0,rDOCON           ; RES sign is set ?
 705             JZ MTIMESDIV8           ; no
 706             XOR #-1,0(PSP)          ; DNEGATE quot
 707             XOR #-1,TOS
 708             ADD #1,0(PSP)
 709             ADDC #0,TOS
 710             CMP #0,&FORTHADDON      ; floored/symetric division flag test
 711             JGE MTIMESDIV8          ; if not(floored division and quot<0)
 712             CMP #0,W                ; remainder <> 0 ?
 713             JZ MTIMESDIV8           ; if not(floored division, quot<0 and remainder <>0)
 714             SUB #1,0(PSP)           ; decrement quotient
 715             SUBC #0,TOS
 716 MTIMESDIV8  MOV #XDODOES,rDODOES
 717             MOV #XDOCON,rDOCON
 718             MOV @IP+,PC             ; 52 words
 719
 720     .ENDIF  ;
 721     .IFNDEF TwoVARIABLE
 722 ; https://forth-standard.org/standard/double/TwoVARIABLE
 723             FORTHWORD "2VARIABLE" ;  --
 724 TwoVARIABLE mDOCOL
 725             .word   CREATE
 726             mNEXTADR
 727             ADD #4,&DP
 728             MOV @RSP+,IP
 729             MOV @IP+,PC
 730
 731     .ENDIF
 732     .IFNDEF TwoCONSTANT
 733 ; https://forth-standard.org/standard/double/TwoCONSTANT
 734             FORTHWORD "2CONSTANT"   ;  udlo/dlo/Flo udhi/dhi/Shi --         to create double or s15q16 CONSTANT
 735 TwoCONSTANT mDOCOL
 736             .word CREATE
 737             .word COMMA,COMMA       ; compile Shi then Flo
 738             .word DOES
 739             .word TWOFETCH          ; execution part
 740             .word EXIT
 741
 742     .ENDIF
 743     .IFNDEF TwoVALUE
 744 ; https://forth-standard.org/standard/double/TwoVALUE
 745             FORTHWORD "2VALUE"      ; x1 x2 "<spaces>name" --
 746 TwoVALUE    mDOCOL
 747             .word CREATE            ; compile Shi then Flo
 748             .word COMMA,COMMA       ; compile Shi then Flo
 749             .word DOES
 750             mNEXTADR
 751             MOV @RSP+,IP
 752             BIT #UF9,SR             ; flag set by TO
 753             JNZ TwoVALUESTO
 754             MOV #TwoFetch,PC              ; execute TwoFetch
 755 TwoVALUESTO BIC #UF9,SR             ; clear flag
 756             MOV #TwoStore,PC              ; execute TwoStore
 757
 758     .ENDIF
 759     .IFNDEF TwoLITERAL
 760 ; https://forth-standard.org/standard/double/TwoLITERAL
 761             FORTHWORDIMM "2LITERAL"
 762 TwoLITERAL  BIS #UF9,SR             ; see LITERAL
 763             MOV #LITERAL,PC
 764
 765     .ENDIF
 766     .IFNDEF DDotR
 767 ; https://forth-standard.org/standard/double/DDotR
 768 ; D.R       d n --
 769             FORTHWORD "D.R"
 770             mDOCOL
 771             .word TOR,SWAP,OVER,DABS,LESSNUM,NUMS,ROT,SIGN,NUMGREATER
 772             .word RFROM,OVER,MINUS,SPACES,TYPE
 773             .word EXIT
 774     .ENDIF