MSP430-FORTH/CORDIC.f

   1 \ -*- coding: utf-8 -*-
   2 \ see CORDICforDummies.pdf
   3 \
   4 \ to see kernel options, download FastForthSpecs.f
   5 \ FastForth kernel options: MSP430ASSEMBLER, CONDCOMP, FIXPOINT_INPUT
   6 \
   7 \
   8 \ TARGET SELECTION ( = the name of \INC\target.pat file without the extension)
   9 \ LP_MSP430FR2476
  10 \ MSP_EXP430FR5739  MSP_EXP430FR5969    MSP_EXP430FR5994    MSP_EXP430FR6989
  11 \ MSP_EXP430FR2433  CHIPSTICK_FR2433    MSP_EXP430FR2355
  12 \
  13 \ from scite editor : copy your target selection in (shift+F8) parameter 1:
  14 \
  15 \ OR
  16 \
  17 \ drag and drop this file onto SendSourceFileToTarget.bat
  18 \ then select your TARGET when asked.
  19 \
  20 \
  21 \ REGISTERS USAGE
  22 \ rDODOES to rEXIT must be saved before use and restored after
  23 \ scratch registers Y to S are free for use
  24 \ under interrupt, IP is free for use
  25 \
  26 \ PUSHM order : PSP,TOS, IP,  S,  T,  W,  X,  Y, rEXIT, rDOVAR, rDOCON, rDODOES
  27 \ example : PUSHM #6,IP pushes IP,S,T,W,X,Y registers to return stack
  28 \
  29 \ POPM  order :  rDODOES, rDOCON, rDOVAR, rEXIT,  Y,  X,  W,  T,  S, IP,TOS,PSP
  30 \ example : POPM #6,IP   pulls Y,X,W,T,S,IP registers from return stack
  31 \
  32 \ FORTH conditionnals:  unary{ 0= 0< 0> }, binary{ = < > U< }
  33 \
  34 \ ASSEMBLER conditionnal usage with IF UNTIL WHILE  S<  S>=  U<   U>=  0=  0<>  0>=
  35 \ ASSEMBLER conditionnal usage with ?JMP ?GOTO      S<  S>=  U<   U>=  0=  0<>  0<
  36
  37 ; ----------
  38 ; CORDIC.f
  39 ; ----------
  40
  41     CODE ABORT_CORDIC
  42     SUB #4,PSP
  43     MOV TOS,2(PSP)
  44     MOV &KERNEL_ADDON,TOS
  45     BIT #BIT8,TOS
  46     0<> IF MOV #0,TOS THEN  \ if TOS <> 0 (FIXPOINT_INPUT), set TOS = 0
  47     MOV TOS,0(PSP)
  48     MOV &VERSION,TOS
  49     SUB #400,TOS        \                   FastForth V4.0
  50     COLON
  51     $0D EMIT            \ return to column 1 without CR
  52     ABORT" FastForth V4.0 please!"
  53     ABORT" build FastForth with FIXPOINT_INPUT addon"
  54     RST_RET             \ if no abort remove this word
  55     ;
  56
  57     ABORT_CORDIC
  58
  59 MARKER {CORDIC}
  60
  61 \ CORDIC USES
  62 \   OPERATION   |   MODE    |   INITIALIZE x y z    |   DIRECTION   |     RESULT        | post operation
  63 \ --------------|-----------|-----------------------|---------------|-------------------|
  64 \ sine, cosine  | Rotation  | x=1, y=0,  z=angle    | Reduce z to 0 | cos=x*Gi,sin=y*Gi | mutiply by 1/Gi
  65 \ --------------|-----------|-----------------------|---------------|-------------------|
  66 \ Polar to Rect | Rotation  | x=magnit, y=0, Z=angle| Reduce z to 0 |  X=x*Gi, Y=y*Gi   | mutiply by 1/Gi
  67 \ --------------|-----------|-----------------------|---------------|-------------------|
  68 \ Rotation      | Rotation  | x=X, y=Y, z=angle     | Reduce z to 0 | X'=x*Gi,Y'=y*Gi   | <=== not implemented
  69 \ --------------|-----------|-----------------------|---------------|-------------------|
  70 \ Rect to Polar |  Vector   | x=X, y=Y, z=0         | Reduce y to 0 | hyp=x*Gi, angle=z | mutiply hyp by 1/Gi
  71 \ --------------|-----------|-----------------------|---------------|-------------------|
  72 \ Gi = CORDIC gain for i iterations; Gi < 1
  73 \
  74     CREATE T_ARCTAN \ ArcTan table
  75     12870 ,         \ 286 * 45      =
  76     7598 ,          \ 286 * 26.565  = 7597,605
  77     4014 ,          \ 286 * 14.036  = 4014,366
  78     2038 ,          \ 286 * 7.125   = 2037,755
  79     1023 ,          \ 286 * 3.576   = 1022,832
  80     512 ,           \ 286 * 1.790   = 511,914
  81     256 ,           \ 286 * 0.895   = 256,020
  82     128 ,           \ 286 * 0.448   = 128,017
  83     64 ,            \ 286 * 0.224   = 64,010
  84     32 ,            \ 286 * 0.112   = 32,005
  85     16 ,            \ 286 * 0.056   = 16,0025
  86     8 ,             \ 286 * 0.028   = 8,00126
  87     4 ,             \ 286 * 0.014   = 4
  88     2 ,             \ 286 * 0.007   = 2
  89     1 ,             \ 286 * 0.003   = 1
  90
  91     CREATE T_SCALE  \ 1/Gi table
  92     46340 ,         \ = 65536 * cos(45)
  93     41448 ,         \ = 65536 * cos(45) * cos(26.565)
  94     40211 ,         \ = 65536 * cos(45) * cos(26.565) * cos(14.036)
  95     39900 ,         \ = 65536 * cos(45) * cos(26.565) * cos(14.036) * ...
  96     39822 ,
  97     39803 ,
  98     39798 ,
  99     39797 ,
 100     39797 ,
 101     39797 ,
 102     39797 ,
 103     39797 ,
 104     39797 ,
 105     39797 ,
 106     39797 ,
 107
 108     [UNDEFINED] DABS [IF]
 109 \ https://forth-standard.org/standard/double/DABS
 110 \ DABS     d1 -- |d1|     absolute value
 111     CODE DABS
 112     AND #-1,TOS         \ clear V, set N
 113     S< IF               \
 114         XOR #-1,0(PSP)  \ 4
 115         XOR #-1,TOS     \ 1
 116         ADD #1,0(PSP)   \ 4
 117         ADDC #0,TOS     \ 1
 118     THEN
 119     MOV @IP+,PC
 120     ENDCODE
 121     [THEN]
 122
 123     [UNDEFINED] R> [IF]
 124 \ https://forth-standard.org/standard/core/Rfrom
 125 \ R>    -- x    R: x --   pop from return stack ; CALL #RFROM performs DOVAR
 126     CODE R>
 127     SUB #2,PSP      \ 1
 128     MOV TOS,0(PSP)  \ 3
 129     MOV @RSP+,TOS   \ 2
 130     MOV @IP+,PC     \ 4
 131     ENDCODE
 132     [THEN]
 133
 134     RST_SET
 135 \ \ https://forth-standard.org/standard/core/Equal
 136 \ \ =      x1 x2 -- flag         test x1=x2
 137 \     [UNDEFINED] =
 138 \     [IF]
 139 \     CODE =
 140 \     SUB @PSP+,TOS   \ 2
 141 \     0<> IF          \ 2
 142 \         AND #0,TOS  \ 1
 143 \         MOV @IP+,PC \ 4
 144 \     THEN
 145 \     XOR #-1,TOS     \ 1 flag Z = 1
 146 \     MOV @IP+,PC     \ 4
 147 \     ENDCODE
 148 \     [THEN]
 149 \
 150 \ \ https://forth-standard.org/standard/core/Uless
 151 \ \ U<    u1 u2 -- flag       test u1<u2, unsigned
 152 \     [UNDEFINED] U<
 153 \     [IF]
 154 \     CODE U<
 155 \     SUB @PSP+,TOS   \ 2 u2-u1
 156 \     0<> IF
 157 \         MOV #-1,TOS     \ 1
 158 \         U< IF           \ 2 flag
 159 \             AND #0,TOS  \ 1 flag Z = 1
 160 \         THEN
 161 \     THEN
 162 \     MOV @IP+,PC     \ 4
 163 \     ENDCODE
 164 \     [THEN]
 165 \
 166 \     $81EF DEVICEID @ U<
 167 \     DEVICEID @ $81F3 U<
 168 \     =
 169
 170     CODE TSTBIT     \ addr bit_mask -- true/flase flag
 171     MOV @PSP+,X
 172     AND @X,TOS
 173     MOV @IP+,PC
 174     ENDCODE
 175
 176     KERNEL_ADDON HMPY TSTBIT \ hardware MPY ?
 177
 178     RST_RET
 179
 180     [IF]   ; MSP430FRxxxx with hardware_MPY
 181
 182         [UNDEFINED] HOLDS [IF]
 183 \ https://forth-standard.org/standard/core/HOLDS
 184 \ Adds the string represented by addr u to the pictured numeric output string
 185 \ compilation use: <# S" string" HOLDS #>
 186 \ free chars area in the 32+2 bytes HOLD buffer = {26,23,2} chars with a 32 bits sized {hexa,decimal,binary} number.
 187 \ (2 supplementary bytes are room for sign - and decimal point)
 188 \ C HOLDS    addr u --
 189         CODE HOLDS
 190         MOV @PSP+,X         \ 2     X=src
 191 BW3     ADD TOS,X           \ 1     X=src_end
 192         MOV &HP,Y           \ 3     Y=dst
 193         BEGIN
 194         SUB #1,X            \ 1     src-1
 195             SUB #1,TOS          \ 1     cnt-1
 196         U>= WHILE
 197             SUB #1,Y            \ 1     dst-1
 198             MOV.B @X,0(Y)       \ 4
 199         REPEAT
 200         MOV Y,&HP           \ 3
 201         MOV @PSP+,TOS       \ 2
 202         MOV @IP+,PC         \ 4  15 words
 203         ENDCODE
 204         [THEN]
 205
 206         [UNDEFINED] F#S [IF]
 207 \ F#S    Qlo Qhi u -- Qhi 0   convert fractionnal part of Q15.16 fixed point number
 208 \                             with u digits
 209         CODE F#S
 210         MOV 2(PSP),X            \ -- Qlo Qhi u      X = Qlo
 211         MOV @PSP,2(PSP)         \ -- Qhi Qhi u
 212         MOV X,0(PSP)            \ -- Qhi Qlo u
 213         MOV TOS,T               \                   T = len
 214         MOV #0,S                \                   S = count
 215         BEGIN
 216             MOV @PSP,&MPY       \                   Load 1st operand
 217             MOV &BASEADR,&OP2   \                   Load 2nd operand
 218             MOV &RES0,0(PSP)    \ -- Qhi RESlo x        low result on stack
 219             MOV &RES1,TOS       \ -- Qhi RESlo REShi    high result in TOS
 220             CMP #10,TOS         \                   digit to char
 221             U>= IF
 222                 ADD #7,TOS
 223             THEN
 224             ADD #$30,TOS
 225             MOV.B TOS,HOLDS_ORG(S)  \ -- Qhi RESlo char     char to string
 226             ADD #1,S            \                   count+1
 227             CMP T,S             \                   count=len ?
 228         0= UNTIL
 229         MOV T,TOS               \ -- len RESlo len
 230         MOV #0,0(PSP)           \ -- Qhi 0 len
 231         MOV #HOLDS_ORG,X        \ -- Qhi 0 len          X=HOLDS_ORG
 232         GOTO BW3                \ 35~ JMP HOLDS+2
 233         ENDCODE
 234         [THEN]
 235
 236         HDNCODE XSCALE          \ X = X*Cordic_Gain
 237         MOV T_SCALE(W),&MPYS32L \ 3     CORDIC Gain * 65536
 238         MOV #0,&MPYS32H
 239         MOV X,&OP2              \ 3     Load 1st operand
 240         MOV &RES1,X             \ 3     hi result
 241         MOV @RSP+,PC            \ RET
 242         ENDCODE
 243
 244     [ELSE] ; no hardware multiplier
 245
 246 \ https://forth-standard.org/standard/core/HOLDS
 247 \ Adds the string represented by addr u to the pictured numeric output string
 248 \ compilation use: <# S" string" HOLDS #>
 249 \ free chars area in the 32+2 bytes HOLD buffer = {26,23,2} chars with a 32 bits sized {hexa,decimal,binary} number.
 250 \ (2 supplementary bytes are room for sign - and decimal point)
 251 \ C HOLDS    addr u --
 252         [UNDEFINED] HOLDS
 253         [IF]
 254         CODE HOLDS
 255         MOV @PSP+,X         \ 2     X=src
 256 BW3     ADD TOS,X           \ 1     X=src_end
 257         MOV &HP,Y           \ 3     Y=dst
 258         BEGIN
 259         SUB #1,X            \ 1     src-1
 260             SUB #1,TOS      \ 1     cnt-1
 261         U>= WHILE
 262             SUB #1,Y        \ 1     dst-1
 263             MOV.B @X,0(Y)   \ 4
 264         REPEAT
 265         MOV Y,&HP           \ 3
 266         MOV @PSP+,TOS       \ 2
 267         MOV @IP+,PC         \ 4  15 words
 268         ENDCODE
 269         [THEN]
 270
 271 \ F#S    Qlo Qhi len -- Qhi 0   convert fractional part Qlo of Q15.16 fixed point number
 272 \                               with len digits
 273         [UNDEFINED] F#S
 274         [IF]
 275         CODE F#S
 276         MOV @PSP,S              \ -- Qlo Qhi len        S = Qhi
 277         MOV #0,T                \                       T = count
 278         PUSHM #3,IP             \                       R-- IP Qhi count
 279         MOV 2(PSP),0(PSP)       \ -- Qlo Qlo len
 280         MOV TOS,2(PSP)          \ -- len Qlo len
 281         BEGIN
 282             MOV &BASEADR,TOS    \ -- len Qlo base
 283             LO2HI
 284             UM*                 \                       u1 u2 -- RESlo REShi
 285             HI2LO               \ -- len RESlo digit
 286             CMP #10,TOS         \                       digit to char
 287             U>= IF
 288                 ADD #7,TOS
 289             THEN
 290             ADD #$30,TOS        \ -- len RESlo char
 291             MOV @RSP,T          \                       T=count
 292             MOV.B TOS,HOLDS_ORG(T)  \                   char to string_org(T)
 293             ADD #1,T            \                       count+1
 294             MOV T,0(RSP)        \
 295             CMP 2(PSP),T        \ -- len RESlo char     count=len ?
 296         U>= UNTIL
 297         POPM #3,IP              \                       S=Qhi, T=len
 298         MOV T,TOS               \ -- len RESlo len
 299         MOV S,2(PSP)            \ -- Qhi RESlo len
 300         MOV #0,0(PSP)           \ -- Qhi 0 len
 301         MOV #HOLDS_ORG,X        \ -- Qhi 0 len          X=HOLDS_ORG
 302         GOTO BW3                \ 36~ JMP HOLDS
 303         ENDCODE
 304         [THEN]
 305
 306 \ T.I. UNSIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud
 307 \ https://forth-standard.org/standard/core/UMTimes
 308 \ UM*     u1 u2 -- ud   unsigned 16x16->32 mult.
 309         HDNCODE XSCALE              \ X --> X*Cordic_Gain
 310         MOV T_SCALE(W),rDOCON   \ rDOCON=MR, X=MDlo
 311         MOV #0,Y                \ 1 MDhi=0
 312         MOV #0,S                \ 1 RES0=0
 313         MOV #0,T                \ 1 RES1=0
 314         MOV #1,W                \ 1 BIT TEST REGISTER
 315         BEGIN
 316             BIT W,rDOCON        \ 1 TEST ACTUAL BIT MRlo
 317             0<> IF
 318                 ADD X,S         \ 1 IF 1: ADD MDlo TO RES0
 319                 ADDC Y,T        \ 1      ADDC MDhi TO RES1
 320             THEN
 321         ADD X,X                 \ 1 (RLA LSBs) MDlo x 2
 322         ADDC Y,Y                \ 1 (RLC MSBs) MDhi x 2
 323         ADD W,W                 \ 1 (RLA) NEXT BIT TO TEST
 324         U>= UNTIL                           \ S = RESlo, T=REShi
 325         MOV T,X                 \ 2 IF BIT IN CARRY: FINISHED    10~ loop
 326         MOV #XDOCON,rDOCON      \ restore rDOCON
 327         MOV @RSP+,PC            \ RET
 328         ENDCODE
 329
 330     [THEN]  ; endcase of hardware multiplier
 331
 332 \ input ; u = module {1000...16384}, F = angle (15Q16 number) in degrees {-89,9...89,9}
 333 \ output ; X Y
 334 \ TOS = Fhi, 0(PSP) = Flo, 2(PSP) = u
 335     CODE POL2REC   \ u F -- X Y
 336     PUSH IP             \ save IP before use
 337     MOV @PSP+,&MPY32L     \ multiply angle by 286
 338     MOV TOS,&MPY32H
 339     MOV #286,&OP2
 340     MOV &RES0,Y
 341     MOV &RES1,TOS       \ -- module angle*286
 342 \ =====================
 343 \ CORDIC 16 bits engine
 344 \ =====================
 345     MOV #-1,IP          \ IP = i-1
 346     MOV @PSP,X          \ X = Xi
 347     MOV #0,Y            \ Y = Yi
 348     BEGIN               \ i loops with init i = -1
 349         ADD #1,IP       \ i = i+1
 350         MOV X,S         \ S = Xi to be right shifted
 351         MOV Y,T         \ T = Yi to be right shifted
 352         MOV #0,W        \
 353         GOTO FW1
 354         BEGIN
 355             RRA S       \ (Xi >> 1)
 356             RRA T       \ (Yi >> 1)
 357             ADD #1,W
 358 FW1         CMP IP,W    \ W = i ?
 359         0= UNTIL        \ loop back if W < i
 360         ADD W,W         \ W = 2i = T_SCALE displacement
 361         CMP #0,TOS      \ TOS = z
 362         0>= IF          \ TOS >= 0 : Rotate clockwise
 363             SUB T,X     \ Xi+1 = Xi - ( Yi >> i)
 364             ADD S,Y     \ Yi+1 = Yi + ( Xi >> i)
 365             SUB T_ARCTAN(W),TOS
 366         ELSE            \ TOS < 0 : Rotate counter-clockwise
 367             ADD T,X     \ Xi+1 = Xi + ( Yi >> i)
 368             SUB S,Y     \ Yi+1 = Yi - ( Xi >> i)
 369             ADD T_ARCTAN(W),TOS
 370         THEN
 371         CMP #0,TOS      \ if angle*256 = 0 quit loop
 372         0<> WHILE       \ search "Extended control-flow patterns" in https://forth-standard.org/standard/rationale
 373             CMP #14,IP  \ IP = size of ARC_TAN table ?
 374     0= UNTIL
 375         THEN            \ search "Extended control-flow patterns" in https://forth-standard.org/standard/rationale
 376 \ multiply cos by factor scale
 377     CALL #XSCALE
 378     MOV X,0(PSP)        \ 3     hi result = cos
 379 \ multiply sin by factor scale
 380     MOV Y,X             \ 3
 381     CALL #XSCALE
 382     MOV X,TOS           \ 3     hi result = sin
 383 \ ==================
 384 \ endof CORDIC engine   \ X = cos, Y = sin
 385 \ ==================
 386     MOV @RSP+,IP
 387     MOV @IP+,PC
 388     ENDCODE                 \ -- cos sin
 389
 390
 391 \ REC2POL version with inputs scaling, to increase the accuracy of the angle:
 392 \ REC2POL   X Y -- u f
 393 \ input : X < 16384, Y < 16384
 394 \ output ; u = hypothenuse, f = angle (15Q16 number) in degrees
 395 \ rounded hypothenuse, 1 mn accuracy angle
 396     CODE REC2POL        \ X Y -- u f
 397     MOV @PSP,X          \ X = Xi
 398     MOV TOS,Y           \ Y = Yi
 399 \ normalize X Y to 16384 maxi
 400 \ 1- calculate T = |Y|
 401     MOV Y,T
 402     CMP #0,T
 403     S< IF
 404         XOR #-1,T
 405         ADD #1,T
 406     THEN
 407 \ 2- calculate S = |X|
 408     MOV X,S
 409     CMP #0,S
 410     S< IF
 411         XOR #-1,S
 412         ADD #1,S
 413     THEN
 414 \ 3- abort if null inputs
 415     MOV #-1,TOS \ set TOS TRUE for the two ABORT" below
 416     CMP #0,X
 417     0= IF
 418         CMP #0,Y
 419         0= IF
 420             LO2HI
 421                 ABORT" null inputs!"
 422             HI2LO
 423         THEN
 424     THEN
 425 \ 4- select max of |X|,|Y|
 426     CMP S,T
 427     U< IF       \ |X| > |Y|
 428         MOV S,T
 429     THEN
 430 \ 5- abort if |X| or |Y| >= 16384
 431     CMP #16384,T
 432         U>= IF
 433         LO2HI
 434             ABORT" |x| or |y| >= 16384"
 435         HI2LO
 436         THEN
 437 \ 6- multiply inputs by 2^n scale factor
 438     MOV #1,S        \ init scale factor
 439     RLAM #3,T       \ test bit 2^13 of max(X,Y)
 440     GOTO FW1
 441     BEGIN
 442         ADD X,X     \ X=X*2
 443         ADD Y,Y     \ Y=Y*2
 444         ADD S,S     \ scale factor *2
 445         ADD T,T     \ to test next bit 2^(n-1)
 446 FW1
 447     U>= UNTIL       \ until carry set
 448 \ 7- save IP and scale factor n
 449     PUSHM #2,IP     \ push IP,S
 450 \ ==================
 451 \ CORDIC 16 bits engine
 452 \ ==================
 453     MOV #-1,IP          \ IP = i-1, X = Xi, Y = Yi
 454     MOV #0,TOS          \ init z=0
 455     BEGIN              \ i loops with init: i = -1
 456         ADD #1,IP       \ i = i+1
 457         MOV X,S         \ S = Xi to be right shifted
 458         MOV Y,T         \ T = Yi to be right shifted
 459         MOV #0,W        \ W = right shift loop count
 460         GOTO FW1
 461         BEGIN
 462             RRA S       \ (X >> i)
 463             RRA T       \ (Y >> i)
 464             ADD #1,W    \
 465 FW1         CMP IP,W    \ W = i ?
 466         0= UNTIL        \ 6~ loop
 467         ADD W,W         \ W = 2i = T_SCALE displacement
 468         CMP #0,Y        \ Y sign ?
 469         S>= IF          \ Y >= 0 : Rotate counter-clockwise
 470             ADD T,X     \ Xi+1 = Xi + ( Yi >> i)
 471             SUB S,Y     \ Yi+1 = Yi - ( Xi >> i)
 472             ADD T_ARCTAN(W),TOS
 473         ELSE            \ Y < 0 : Rotate clockwise
 474             SUB T,X     \ Xi+1 = Xi - ( Yi >> i)
 475             ADD S,Y     \ Yi+1 = Yi + ( Xi >> i)
 476             SUB T_ARCTAN(W),TOS
 477         THEN
 478         CMP #0,Y        \
 479         0<> WHILE       \ if Y = 0 quit loop ---+
 480         CMP #14,IP      \                       |
 481     0= UNTIL           \                       |
 482         THEN            \ <---------------------+
 483 \ multiply x by CORDIC gain
 484     CALL #XSCALE             \ 3     hi result = hypothenuse
 485 \ ==================
 486 \ endof CORDIC engine   \ X = hypothenuse, TOS = 256*angle
 487 \ ==================
 488 \ divide x by scale factor
 489     POPM #2,IP              \ S = scale factor, restore IP
 490     GOTO FW1
 491     BEGIN                   \ 4~ loop
 492         RRA X               \ divide x by 2
 493 FW1     RRA S               \ shift right scale factor
 494     U>= UNTIL               \ until carry set
 495     MOV X,0(PSP)
 496 \ divide z by 286 to display it as a Q15.16 number
 497     SUB #4,PSP              \ -- X * * Zhi
 498     MOV TOS,rDOCON          \ -- rDOCON as sign of QUOT
 499     CMP #0,rDOCON
 500     S< IF
 501         XOR #-1,TOS
 502         ADD #1,TOS
 503     THEN
 504     MOV #0,2(PSP)           \ -- X Zlo * Zhi
 505     MOV TOS,0(PSP)          \ -- X Zlo Zhi Zhi
 506     MOV #286,TOS            \ -- X Zlo Zhi DIV
 507     CALL #MUSMOD            \ -- X rem QUOTlo QUOThi
 508     MOV @PSP+,0(PSP)        \    remove remainder
 509     CMP #0,rDOCON
 510     S< IF
 511         XOR #-1,0(PSP)
 512         XOR #-1,TOS
 513         ADD #1,0(PSP)
 514         ADDC #0,TOS
 515     THEN
 516     MOV #XDOCON,rDOCON
 517     MOV @IP+,PC
 518     ENDCODE
 519
 520
 521     [UNDEFINED] F. [IF]
 522     CODE F.             \ display a Q15.16 number with 4/5/16 digits after comma
 523     MOV TOS,S           \ S = sign
 524     MOV #4,T            \ T = 4     preset 4 digits for base 16 and by default
 525     MOV &BASEADR,W
 526     CMP ##10,W
 527     0= IF               \           if base 10
 528         ADD #1,T        \ T = 5     set 5 digits
 529     ELSE
 530         CMP #%10,W
 531         0= IF           \           if base 2
 532             MOV #16,T   \ T = 16    set 16 digits
 533         THEN
 534     THEN
 535     PUSHM #3,IP         \                   R-- IP sign #digit
 536     LO2HI
 537         <# DABS         \ -- uQlo uQhi      R-- IP sign #digit
 538         R> F#S          \ -- uQhi 0         R-- IP sign
 539         $2C HOLD        \                   $2C = char ','
 540         #S              \ -- 0 0
 541         R> SIGN #>      \ -- addr len       R-- IP
 542         TYPE $20 EMIT   \ --
 543     ;
 544
 545     [THEN]
 546
 547 RST_SET
 548
 549 \ https://forth-standard.org/standard/core/SWAP
 550 \ SWAP     x1 x2 -- x2 x1    swap top two items
 551     [UNDEFINED] SWAP [IF]
 552     CODE SWAP
 553     MOV @PSP,W      \ 2
 554     MOV TOS,0(PSP)  \ 3
 555     MOV W,TOS       \ 1
 556     MOV @IP+,PC     \ 4
 557     ENDCODE
 558     [THEN]
 559
 560 \ https://forth-standard.org/standard/core/ROT
 561 \ ROT    x1 x2 x3 -- x2 x3 x1
 562     [UNDEFINED] ROT [IF] \
 563     CODE ROT
 564     MOV @PSP,W          \ 2 fetch x2
 565     MOV TOS,0(PSP)      \ 3 store x3
 566     MOV 2(PSP),TOS      \ 3 fetch x1
 567     MOV W,2(PSP)        \ 3 store x2
 568     MOV @IP+,PC
 569     ENDCODE
 570     [THEN]
 571
 572 ECHO
 573
 574 10000 89,0 POL2REC . .  ; sin, cos -->
 575 10000 75,0 POL2REC . .  ; sin, cos -->
 576 10000 60,0 POL2REC . .  ; sin, cos -->
 577 10000 45,0 POL2REC . .  ; sin, cos -->
 578 10000 30,0 POL2REC . .  ; sin, cos -->
 579 10000 15,0 POL2REC . .  ; sin, cos -->
 580 10000 1,0 POL2REC . .   ; sin, cos -->
 581 \ module phase -- X Y
 582 16384 30,0 POL2REC SWAP . . ; x, y -->
 583 16384 45,0 POL2REC SWAP . . ; x, y -->
 584 16384 60,0 POL2REC SWAP . . ; x, y -->
 585
 586 \
 587 10000 -89,0 POL2REC . .  ; sin, cos -->
 588 10000 -75,0 POL2REC . .  ; sin, cos -->
 589 10000 -60,0 POL2REC . .  ; sin, cos -->
 590 10000 -45,0 POL2REC . .  ; sin, cos -->
 591 10000 -30,0 POL2REC . .  ; sin, cos -->
 592 10000 -15,0 POL2REC . .  ; sin, cos -->
 593 10000 -1,0 POL2REC . .   ; sin, cos -->
 594 \ module phase -- X Y
 595 16384 -30,0 POL2REC SWAP . . ; x, y -->
 596 16384 -45,0 POL2REC SWAP . . ; x, y -->
 597 16384 -60,0 POL2REC SWAP . . ; x, y -->
 598
 599 \
 600 -10000 89,0 POL2REC . .  ; sin, cos -->
 601 -10000 75,0 POL2REC . .  ; sin, cos -->
 602 -10000 60,0 POL2REC . .  ; sin, cos -->
 603 -10000 45,0 POL2REC . .  ; sin, cos -->
 604 -10000 30,0 POL2REC . .  ; sin, cos -->
 605 -10000 15,0 POL2REC . .  ; sin, cos -->
 606 -10000 1,0 POL2REC . .   ; sin, cos -->
 607 \ module phase -- X Y
 608 -16384 30,0 POL2REC SWAP . . ; x, y -->
 609 -16384 45,0 POL2REC SWAP . . ; x, y -->
 610 -16384 60,0 POL2REC SWAP . . ; x, y -->
 611 \
 612
 613 -10000 -89,0 POL2REC . .  ; sin, cos -->
 614 -10000 -75,0 POL2REC . .  ; sin, cos -->
 615 -10000 -60,0 POL2REC . .  ; sin, cos -->
 616 -10000 -45,0 POL2REC . .  ; sin, cos -->
 617 -10000 -30,0 POL2REC . .  ; sin, cos -->
 618 -10000 -15,0 POL2REC . .  ; sin, cos -->
 619 -10000 -1,0 POL2REC . .   ; sin, cos -->
 620 \ module phase -- X Y
 621 -16384 -30,0 POL2REC SWAP . . ; x, y -->
 622 -16384 -45,0 POL2REC SWAP . . ; x, y -->
 623 -16384 -60,0 POL2REC SWAP . . ; x, y -->
 624 \
 625
 626
 627 2  1  REC2POL F. .          ; phase module -->
 628 2 -1  REC2POL F. .          ; phase module -->
 629 20  10  REC2POL F. .        ; phase module -->
 630 20 -10  REC2POL F. .        ; phase module -->
 631 200 100 REC2POL F. .        ; phase module -->
 632 100 -100 REC2POL F. .       ; phase module -->
 633 2000 1000 REC2POL F. .      ; phase module -->
 634 1000 -1000 REC2POL F. .     ; phase module -->
 635 16000 8000 REC2POL F. .     ; phase module -->
 636 16000 -8000 REC2POL F. .    ; phase module -->
 637 16000 0 REC2POL F. .        ; phase module -->
 638 0 16000 REC2POL F. .        ; phase module -->
 639 \ 16384 -8192 REC2POL F. .    ; --> abort
 640 \ 0 0 REC2POL F. .            ; --> abort
 641
 642 -2  1  REC2POL F. .          ; phase module -->
 643 -2 -1  REC2POL F. .          ; phase module -->
 644 -20  10  REC2POL F. .        ; phase module -->
 645 -20 -10  REC2POL F. .        ; phase module -->
 646 -200 100 REC2POL F. .        ; phase module -->
 647 -100 -100 REC2POL F. .       ; phase module -->
 648 -2000 1000 REC2POL F. .      ; phase module -->
 649 -1000 -1000 REC2POL F. .     ; phase module -->
 650 -16000 8000 REC2POL F. .     ; phase module -->
 651 -16000 -8000 REC2POL F. .    ; phase module -->
 652 16000 0 REC2POL F. .        ; phase module -->
 653 0 16000 REC2POL F. .        ; phase module -->
 654 \ 16384 -8192 REC2POL F. .    ; --> abort
 655 \ 0 0 REC2POL F. .            ; --> abort
 656
 657 10000 89,0 POL2REC REC2POL   ROT . F.
 658 10000 75,0 POL2REC REC2POL   ROT . F.
 659 10000 60,0 POL2REC REC2POL   ROT . F.
 660 10000 45,0 POL2REC REC2POL   ROT . F.
 661 10000 30,0 POL2REC REC2POL   ROT . F.
 662 10000 26,565 POL2REC REC2POL ROT . F.
 663 10000 15,0 POL2REC REC2POL   ROT . F.
 664 10000 14,036 POL2REC REC2POL ROT . F.
 665 10000 7,125 POL2REC REC2POL  ROT . F.
 666 10000 1,0 POL2REC REC2POL    ROT . F.
 667
 668