MSP430-FORTH/FixPoint.f

   1 \ -*- coding: utf-8 -*-
   2
   3 ; -----------------------------------------------------
   4 ; FIXPOINT.f
   5 ; -----------------------------------------------------
   6
   7 ; -----------------------------------------------------------
   8 ; requires FIXPOINT_INPUT kernel addon, see forthMSP430FR.asm
   9 ; -----------------------------------------------------------
  10 \
  11 \ to see kernel options, download FastForthSpecs.f
  12 \ FastForth kernel options: MSP430ASSEMBLER, CONDCOMP, FIXPOINT_INPUT
  13 \
  14 \ TARGET SELECTION
  15 \ MSP_EXP430FR5739  MSP_EXP430FR5969    MSP_EXP430FR5994    MSP_EXP430FR6989
  16 \ MSP_EXP430FR2433  MSP_EXP430FR4133    MSP_EXP430FR2355    CHIPSTICK_FR2433
  17 \
  18 \ REGISTERS USAGE
  19 \ rDODOES to rEXIT must be saved before use and restored after
  20 \ scratch registers Y to S are free for use
  21 \ under interrupt, IP is free for use
  22 \
  23 \ PUSHM order : PSP,TOS, IP,  S,  T,  W,  X,  Y, rEXIT,rDOVAR,rDOCON, rDODOES, R3, SR,RSP, PC
  24 \ PUSHM order : PSP,TOS,IP,S,T,W, X, Y,  rDOCOL  ,  rDOVAR  ,  rDOCON  ,   rDODOES   , R3, SR, RSP, PC
  25 \
  26 \ example : PUSHM #6,IP pushes IP,S,T,W,X,Y registers to return stack
  27 \
  28 \ POPM  order :  PC,RSP, SR, R3, rDODOES,rDOCON,rDOVAR,rEXIT,  Y,  X,  W,  T,  S, IP,TOS,PSP
  29 \ POPM  order :  PC, RSP, SR, R3,   rDODOES   ,  rDOCON  ,  rDOVAR  ,  rDOCOL , Y, X,W,T,S,IP,TOS,PSP
  30 \
  31 \ example : POPM #6,IP   pop Y,X,W,T,S,IP registers from return stack
  32 \
  33 \ FORTH conditionnals:  unary{ 0= 0< 0> }, binary{ = < > U< }
  34 \
  35 \ ASSEMBLER conditionnal usage with IF UNTIL WHILE  S<  S>=  U<   U>=  0=  0<>  0>=
  36 \ ASSEMBLER conditionnal usage with ?JMP ?GOTO      S<  S>=  U<   U>=  0=  0<>  0<
  37 \
  38
  39 PWR_STATE
  40
  41 [DEFINED] {FIXPOINT} [IF]  {FIXPOINT} [THEN]
  42
  43 [UNDEFINED] {FIXPOINT} [IF]
  44
  45 MARKER {FIXPOINT}
  46
  47 [UNDEFINED] + [IF]
  48 \ https://forth-standard.org/standard/core/Plus
  49 \ +       n1/u1 n2/u2 -- n3/u3     add n1+n2
  50 CODE +
  51 ADD @PSP+,TOS
  52 MOV @IP+,PC
  53 ENDCODE
  54 [THEN]
  55
  56 [UNDEFINED] @ [IF]
  57 \ https://forth-standard.org/standard/core/Fetch
  58 \ @     c-addr -- char   fetch char from memory
  59 CODE @
  60 MOV @TOS,TOS
  61 MOV @IP+,PC
  62 ENDCODE
  63 [THEN]
  64
  65 [UNDEFINED] R> [IF]
  66 \ https://forth-standard.org/standard/core/Rfrom
  67 \ R>    -- x    R: x --   pop from return stack ; CALL #RFROM performs DOVAR
  68 CODE R>
  69 SUB #2,PSP      \ 1
  70 MOV TOS,0(PSP)  \ 3
  71 MOV @RSP+,TOS   \ 2
  72 MOV @IP+,PC     \ 4
  73 ENDCODE
  74 [THEN]
  75
  76 [UNDEFINED] = [IF]
  77 \ https://forth-standard.org/standard/core/Equal
  78 \ =      x1 x2 -- flag         test x1=x2
  79 CODE =
  80 SUB @PSP+,TOS   \ 2
  81 0<> IF          \ 2
  82     AND #0,TOS  \ 1
  83     MOV @IP+,PC \ 4
  84 THEN
  85 XOR #-1,TOS     \ 1 flag Z = 1
  86 MOV @IP+,PC     \ 4
  87 ENDCODE
  88 [THEN]
  89
  90 \ https://forth-standard.org/standard/core/Uless
  91 \ U<    u1 u2 -- flag       test u1<u2, unsigned
  92 [UNDEFINED] U< [IF]
  93 CODE U<
  94 SUB @PSP+,TOS   \ 2 u2-u1
  95 0<> IF
  96     MOV #-1,TOS     \ 1
  97     U< IF           \ 2 flag
  98         AND #0,TOS  \ 1 flag Z = 1
  99     THEN
 100 THEN
 101 MOV @IP+,PC     \ 4
 102 ENDCODE
 103 [THEN]
 104
 105 [UNDEFINED] DABS [IF]
 106 \ https://forth-standard.org/standard/double/DABS
 107 \ DABS     d1 -- |d1|     absolute value
 108 CODE DABS
 109 AND #-1,TOS         \ clear V, set N
 110 S< IF               \
 111     XOR #-1,0(PSP)  \ 4
 112     XOR #-1,TOS     \ 1
 113     ADD #1,0(PSP)   \ 4
 114     ADDC #0,TOS     \ 1
 115 THEN
 116 MOV @IP+,PC
 117 ENDCODE
 118 [THEN]
 119
 120 [UNDEFINED] HOLDS [IF]
 121 \ https://forth-standard.org/standard/core/HOLDS
 122 \ Adds the string represented by addr u to the pictured numeric output string
 123 \ compilation use: <# S" string" HOLDS #>
 124 \ free chars area in the 32+2 bytes HOLD buffer = {26,23,2} chars with a 32 bits sized {hexa,decimal,binary} number.
 125 \ (2 supplementary bytes are room for sign - and decimal point)
 126 \ C HOLDS    addr u --
 127 CODE HOLDS
 128             MOV @PSP+,X         \ 2     X=src
 129 BW3         ADD TOS,X           \ 1     X=src_end
 130             MOV &HP,Y           \ 3     Y=dst
 131 BEGIN       SUB #1,X            \ 1     src-1
 132             SUB #1,TOS          \ 1     cnt-1
 133 U>= WHILE   SUB #1,Y            \ 1     dst-1
 134             MOV.B @X,0(Y)       \ 4
 135 REPEAT      MOV Y,&HP           \ 3
 136             MOV @PSP+,TOS       \ 2
 137             MOV @IP+,PC         \ 4  15 words
 138 ENDCODE
 139 [THEN]
 140
 141 CODE F+                         \ add Q15.16|double numbers
 142             ADD @PSP+,2(PSP)    \ -- sumlo  d1hi d2hi
 143             ADDC @PSP+,TOS      \ -- sumlo sumhi
 144             MOV @IP+,PC
 145 ENDCODE
 146
 147 CODE F-                         \ substract Q15.16|double numbers
 148             SUB @PSP+,2(PSP)    \ -- diflo d1hi d2hi
 149             SUBC TOS,0(PSP)     \ -- diflo difhi d2hi
 150             MOV @PSP+,TOS
 151             MOV @IP+,PC
 152 ENDCODE
 153
 154 TLV_ORG 4 + @ $81F3 U<
 155 $81EF TLV_ORG 4 + @ U<
 156 = [IF]   ; MSP430FR413x subfamily without hardware_MPY
 157
 158 \ unsigned multiply 32*32 = 64
 159 \ don't use S reg (keep sign)
 160 CODE UDM*
 161             PUSH IP             \ 3
 162             PUSHM #4,rDOVAR     \ 6 save rDOVAR to rDOCOL regs to use M to R alias
 163             MOV 4(PSP),IP       \ 3 MDlo
 164             MOV 2(PSP),T        \ 3 MDhi
 165             MOV @PSP,W          \ 2 MRlo
 166             MOV #0,M            \ 1 MDLO=0
 167             MOV #0,P            \ 1 MDHI=0
 168             MOV #0,4(PSP)       \ 3 RESlo=0
 169             MOV #0,2(PSP)       \ 3 REShi=0
 170             MOV #0,Q            \ 1 RESLO=0
 171             MOV #0,R            \ 1 RESHI=0
 172             MOV #1,X            \ 1 BIT TEST REGlo
 173             MOV #0,Y            \ 1 BIT TEST2 REGhi
 174 BEGIN       CMP #0,X
 175     0<> IF  BIT X,W             \ 2+1 TEST ACTUAL BIT MRlo
 176     ELSE    BIT Y,TOS           \ 2+1 TEST ACTUAL BIT MRhi
 177     THEN
 178     0<> IF  ADD IP,4(PSP)       \ 2+3 IF 1: ADD MDlo TO RESlo
 179             ADDC T,2(PSP)       \ 3      ADDC MDhi TO REShi
 180             ADDC M,Q            \ 1      ADDC MDLO TO RESLO
 181             ADDC P,R            \ 1      ADDC MDHI TO RESHI
 182     THEN    ADD IP,IP           \ 1 (RLA LSBs) MDlo *2
 183             ADDC T,T            \ 1 (RLC MSBs) MDhi *2
 184             ADDC M,M            \ 1 (RLC LSBs) MDLO *2
 185             ADDC P,P            \ 1 (RLC MSBs) MDHI *2
 186             ADD X,X             \ 1 (RLA) NEXT BIT TO TEST
 187             ADDC Y,Y            \ 1 (RLC) NEXT BIT TO TEST
 188 U>= UNTIL   MOV Q,0(PSP)        \ 2+2 IF BIT IN CARRY: FINISHED    32 * 16~ (average loop)
 189             MOV R,TOS           \ 1 high result in TOS
 190             POPM #4,rDOVAR      \ 6 restore rDOCOL to rDOVAR
 191             MOV @RSP+,IP        \ 2
 192             MOV @IP+,PC
 193 ENDCODE
 194
 195 CODE F*                         \ s15.16 * s15.16 --> s15.16 result
 196             MOV 2(PSP),S        \
 197             XOR TOS,S           \ 1s15 XOR 2s15 --> S keep sign of result
 198             BIT #$8000,2(PSP)   \ MD < 0 ?
 199 0<> IF      XOR #-1,2(PSP)
 200             XOR #-1,4(PSP)
 201             ADD #1,4(PSP)
 202             ADDC #0,2(PSP)
 203 THEN        COLON
 204             DABS UDM*           \ -- RES0 RES1 RES2 RES3
 205             HI2LO
 206             MOV @RSP+,IP
 207             MOV @PSP+,TOS       \ -- RES0 RES1 RES2
 208             MOV @PSP+,0(PSP)    \ -- RES1 RES2
 209 BW2         AND #-1,S           \ clear V, set N; process S sign
 210 S< IF       XOR #-1,0(PSP)      \ INV(QUOTlo)
 211             XOR #-1,TOS         \ INV(QUOThi)
 212             ADD #1,0(PSP)       \ INV(QUOTlo)+1
 213             ADDC #0,TOS         \ INV(QUOThi)+C
 214 THEN        MOV @IP+,PC
 215 ENDCODE
 216
 217 CODE F/                         \ Q15.16 / Q15.16 --> Q15.16 result
 218             PUSHM #4,rDOVAR     \ 6 save rDOVAR to rDOCOL regs to use M to R alias
 219             MOV @PSP+,M         \ DVRlo
 220             MOV @PSP+,X         \ DVDhi --> REMlo
 221             MOV #0,W            \ REMhi = 0
 222             MOV @PSP,Y          \ DVDlo --> DVDhi
 223             MOV #0,T            \ DVDlo = 0
 224             MOV X,S             \
 225             XOR TOS,S           \ DVDhi XOR DVRhi --> S keep sign of result
 226             AND #-1,X           \ DVD < 0 ?
 227 S< IF       XOR #-1,Y           \ INV(DVDlo)
 228             XOR #-1,X           \ INV(DVDhi)
 229             ADD #1,Y            \ INV(DVDlo)+1
 230             ADDC #0,X           \ INV(DVDhi)+C
 231 THEN        AND #-1,TOS         \ DVR < 0 ?
 232 S< IF       XOR #-1,M           \ INV(DVRlo)
 233             XOR #-1,TOS         \ INV(DVRhi)
 234             ADD #1,M            \ INV(DVRlo)+1
 235             ADDC #0,TOS         \ INV(DVRhi)+C
 236 THEN
 237 \ don't uncomment lines below !
 238 \ ------------------------------------------------------------------------
 239 \           UD/MOD    DVDlo DVDhi DVRlo DVRhi -- REMlo REMhi QUOTlo QUOThi
 240 \ ------------------------------------------------------------------------
 241 \           MOV 4(PSP),T        \ DVDlo
 242 \           MOV 2(PSP),Y        \ DVDhi
 243 \           MOV #0,X            \ REMlo = 0
 244 \           MOV #0,W            \ REMhi = 0
 245             MOV #32,P           \  init loop count
 246 BW1         CMP TOS,W           \ 1 REMhi = DVRhi ?
 247     0= IF   CMP M,X             \ 1 REMlo U< DVRlo ?
 248     THEN
 249     U>= IF  SUB M,X             \ 1 no:  REMlo - DVRlo  (carry is set)
 250             SUBC TOS,W          \ 1      REMhi - DVRhi
 251     THEN
 252     BEGIN   ADDC R,R            \ 1 RLC quotLO
 253             ADDC Q,Q            \ 1 RLC quotHI
 254             SUB #1,P            \ 1 Decrement loop counter
 255             0< ?GOTO FW1        \ 2 out of loop if count<0
 256             ADD T,T             \ 1 RLA DVDlo
 257             ADDC Y,Y            \ 1 RLC DVDhi
 258             ADDC X,X            \ 1 RLC REMlo
 259             ADDC W,W            \ 1 RLC REMhi
 260             U< ?GOTO BW1        \ 2 15~ loop
 261             SUB M,X             \ 1 REMlo - DVRlo
 262             SUBC TOS,W          \ 1 REMhi - DVRhi
 263             BIS #1,SR           \ 1
 264     AGAIN                       \ 2 16~ loop
 265 FW1
 266 \           MOV X,4(PSP)        \ REMlo
 267 \           MOV W,2(PSP)        \ REMhi
 268 \           ADD #4,PSP          \ skip REMlo REMhi
 269             MOV R,0(PSP)        \ QUOTlo
 270             MOV Q,TOS           \ QUOThi
 271             POPM #4,rDOVAR      \ 6 restore rDOCOL to rDOVAR
 272 \           MOV @IP+,PC         \ end of UD/MOD
 273 \ ------------------------------------------------------------------------
 274             GOTO BW2            \ to process S sign
 275 ENDCODE
 276
 277 [UNDEFINED] F#S [IF]
 278 \ F#S    Qlo Qhi len -- Qhi 0   convert fractional part Qlo of Q15.16 fixed point number
 279 \                               with len digits
 280 CODE F#S
 281             MOV @PSP,S          \ -- Qlo Qhi len        S = Qhi
 282             MOV #0,T            \                       T = count
 283             PUSHM #3,IP         \                       R-- IP Qhi count
 284             MOV 2(PSP),0(PSP)   \ -- Qlo Qlo len
 285             MOV TOS,2(PSP)      \ -- len Qlo len
 286 BEGIN       MOV &BASEADR,TOS    \ -- len Qlo base
 287             LO2HI
 288             UM*                 \                       u1 u2 -- RESlo REShi
 289             HI2LO               \ -- len RESlo digit
 290             CMP #10,TOS         \                       digit to char
 291     U>= IF  ADD #7,TOS
 292     THEN    ADD #$30,TOS        \ -- len RESlo char
 293             MOV @RSP,T          \                       T=count
 294             MOV.B TOS,HOLDS_ORG(T)  \                   char to string_org(T)
 295             ADD #1,T            \                       count+1
 296             MOV T,0(RSP)        \
 297             CMP 2(PSP),T        \ -- len RESlo char     count=len ?
 298 U>= UNTIL   POPM #3,IP          \                       S=Qhi, T=len
 299             MOV T,TOS           \ -- len RESlo len
 300             MOV S,2(PSP)        \ -- Qhi RESlo len
 301             MOV #0,0(PSP)       \ -- Qhi 0 len
 302             MOV #HOLDS_ORG,X    \ -- Qhi 0 len          X=HOLDS_ORG
 303             GOTO BW3            \ 36~ JMP HOLDS
 304 ENDCODE
 305 [THEN]
 306
 307 [ELSE] ; hardware multiplier
 308
 309 CODE F/                         \ Q15.16 / Q15.16 --> Q15.16 result
 310 \ TOS = DVRhi
 311 \ 0(PSP) = DVRlo
 312 \ 2(PSP) = DVDhi
 313 \ 4(PSP) = DVDlo
 314             PUSHM #4,rDOVAR     \ 6 PUSHM rDOVAR to rDOCOL to use M to R alias
 315             MOV @PSP+,M         \ 2 DVRlo
 316             MOV @PSP+,X         \ 2 DVDhi --> REMlo
 317             MOV #0,W            \ 1 REMhi = 0
 318             MOV @PSP,Y          \ 2 DVDlo --> DVDhi
 319             MOV #0,T            \ 1 DVDlo = 0
 320             MOV X,S             \ 1
 321             XOR TOS,S           \ 1 DVDhi XOR DVRhi --> S keep sign of result
 322             AND #-1,X           \ 1 DVD < 0 ?
 323 S< IF       XOR #-1,Y           \ 1 INV(DVDlo)
 324             XOR #-1,X           \ 1 INV(DVDhi)
 325             ADD #1,Y            \ 1 INV(DVDlo)+1
 326             ADDC #0,X           \ 1 INV(DVDhi)+C
 327 THEN        AND #-1,TOS         \ 1 DVRhi < 0 ?
 328 S< IF       XOR #-1,M           \ 1 INV(DVRlo)
 329             XOR #-1,TOS         \ 1 INV(DVRhi)
 330             ADD #1,M            \ 1 INV(DVRlo)+1
 331             ADDC #0,TOS         \ 1 INV(DVRhi)+C
 332 THEN
 333 \ don't uncomment lines below !
 334 \ ------------------------------------------------------------------------
 335 \           UD/MOD    DVDlo DVDhi DVRlo DVRhi -- REMlo REMhi QUOTlo QUOThi
 336 \ ------------------------------------------------------------------------
 337 \           MOV 4(PSP),T        \ DVDlo
 338 \           MOV 2(PSP),Y        \ DVDhi
 339 \           MOV #0,X            \ REMlo = 0
 340 \           MOV #0,W            \ REMhi = 0
 341             MOV #32,P           \ 2 init loop count
 342 BW1         CMP TOS,W           \ 1 REMhi = DVRhi ?
 343     0= IF   CMP M,X             \ 1 REMlo U< DVRlo ?
 344     THEN
 345     U>= IF  SUB M,X             \ 1 no:  REMlo - DVRlo  (carry is set)
 346             SUBC TOS,W          \ 1      REMhi - DVRhi
 347     THEN
 348 BW2         ADDC R,R            \ 1 RLC quotLO
 349             ADDC Q,Q            \ 1 RLC quotHI
 350             SUB #1,P            \ 1 Decrement loop counter
 351             0< ?GOTO FW1        \ 2 out of loop if count<0
 352             ADD T,T             \ 1 RLA DVDlo
 353             ADDC Y,Y            \ 1 RLC DVDhi
 354             ADDC X,X            \ 1 RLC REMlo
 355             ADDC W,W            \ 1 RLC REMhi
 356             U< ?GOTO BW1        \ 2 19~ loop
 357             SUB M,X             \ 1 REMlo - DVRlo
 358             SUBC TOS,W          \ 1 REMhi - DVRhi
 359             BIS #1,SR           \ 1
 360             GOTO BW2            \ 2 16~ loop
 361 FW1         AND #-1,S           \ 1 clear V, set N; QUOT < 0 ?
 362 S< IF       XOR #-1,R           \ 1 INV(QUOTlo)
 363             XOR #-1,Q           \ 1 INV(QUOThi)
 364             ADD #1,R            \ 1 INV(QUOTlo)+1
 365             ADDC #0,Q           \ 1 INV(QUOThi)+C
 366 THEN        MOV R,0(PSP)        \ 3 QUOTlo
 367             MOV Q,TOS           \ 1 QUOThi
 368             POPM #4,rDOVAR      \ 6 restore rDOCOL to rDOVAR
 369             MOV @IP+,PC         \ 4
 370 ENDCODE
 371
 372 [UNDEFINED] F#S [IF]
 373 \ F#S    Qlo Qhi u -- Qhi 0   convert fractionnal part of Q15.16 fixed point number
 374 \                             with u digits
 375 CODE F#S
 376             MOV 2(PSP),X        \ -- Qlo Qhi u      X = Qlo
 377             MOV @PSP,2(PSP)     \ -- Qhi Qhi u
 378             MOV X,0(PSP)        \ -- Qhi Qlo u
 379             MOV TOS,T           \                   T = len
 380             MOV #0,S            \                   S = count
 381 BEGIN       MOV @PSP,&MPY       \                   Load 1st operand
 382             MOV &BASEADR,&OP2   \                   Load 2nd operand
 383             MOV &RES0,0(PSP)    \ -- Qhi RESlo x        low result on stack
 384             MOV &RES1,TOS       \ -- Qhi RESlo REShi    high result in TOS
 385             CMP #10,TOS         \                   digit to char
 386     U>= IF  ADD #7,TOS
 387     THEN    ADD #$30,TOS
 388             MOV.B TOS,HOLDS_ORG(S)  \ -- Qhi RESlo char     char to string
 389             ADD #1,S            \                   count+1
 390             CMP T,S             \                   count=len ?
 391 0= UNTIL    MOV T,TOS           \ -- len RESlo len
 392             MOV #0,0(PSP)       \ -- Qhi 0 len
 393             MOV #HOLDS_ORG,X    \ -- Qhi 0 len          X=HOLDS_ORG
 394             GOTO BW3            \ 35~ JMP HOLDS+2
 395 ENDCODE
 396 [THEN]
 397
 398 CODE F*                         \ signed s15.16 multiplication --> s15.16 result
 399             MOV 4(PSP),&MPYS32L \ 5 Load 1st operand
 400             MOV 2(PSP),&MPYS32H \ 5
 401             MOV @PSP,&OP2L      \ 4 load 2nd operand
 402             MOV TOS,&OP2H       \ 3
 403             ADD #4,PSP          \ 1 remove 2 cells
 404             MOV &RES1,0(PSP)    \ 5
 405             MOV &RES2,TOS       \ 5
 406             MOV @IP+,PC
 407 ENDCODE
 408
 409 [THEN]  \ endcase of hardware multiplier
 410
 411 [UNDEFINED] F. [IF]
 412 CODE F.             \ display a Q15.16 number with 4/5/16 digits after comma
 413 MOV TOS,S           \ S = sign
 414 MOV #4,T            \ T = 4     preset 4 digits for base 16 and by default
 415 MOV &BASEADR,W
 416 CMP #$0A,W
 417 0= IF               \           if base 10
 418     ADD #1,T        \ T = 5     set 5 digits
 419 ELSE
 420     CMP #2,W
 421     0= IF           \           if base 2
 422         MOV #$10,T  \ T = 16    set 16 digits
 423     THEN
 424 THEN
 425 PUSHM #3,IP         \                   R-- IP sign #digit
 426 LO2HI
 427     <# DABS         \ -- uQlo uQhi      R-- IP sign #digit
 428     R> F#S          \ -- uQhi 0         R-- IP sign
 429     $2C HOLD        \                   $2C = char ','
 430     #S              \ -- 0 0
 431     R> SIGN #>      \ -- addr len       R-- IP
 432     TYPE $20 EMIT   \ --
 433 ;
 434
 435 CODE S>F            \ convert a signed number to a Q15.16 (signed) number
 436     SUB #2,PSP
 437     MOV #0,0(PSP)
 438     MOV @IP+,PC
 439 ENDCODE
 440 [THEN]
 441
 442 PWR_HERE
 443
 444 [THEN] \ endof [UNDEFINED] {FIXPOINT}
 445
 446 ; -----------------------
 447 ; definitions (volatile) for tests below
 448 ; -----------------------
 449
 450 [UNDEFINED] ! [IF]
 451 \ https://forth-standard.org/standard/core/Store
 452 \ !        x a-addr --   store cell in memory
 453 CODE !
 454 MOV @PSP+,0(TOS)    \ 4
 455 MOV @PSP+,TOS       \ 2
 456 MOV @IP+,PC         \ 4
 457 ENDCODE
 458 [THEN]
 459
 460 [UNDEFINED] DOES> [IF]
 461 \ https://forth-standard.org/standard/core/DOES
 462 \ DOES>    --          set action for the latest CREATEd definition
 463 CODE DOES>
 464 MOV &LAST_CFA,W         \ W = CFA of CREATEd word
 465 MOV #DODOES,0(W)        \ replace CFA (DOCON) by new CFA (DODOES)
 466 MOV IP,2(W)             \ replace PFA by the address after DOES> as execution address
 467 MOV @RSP+,IP
 468 MOV @IP+,PC
 469 ENDCODE
 470 [THEN]
 471
 472 [UNDEFINED] 2CONSTANT [IF]
 473 \ https://forth-standard.org/standard/double/TwoCONSTANT
 474 : 2CONSTANT \  udlo/dlo/Qlo udhi/dhi/Qhi --         to create double or Q15.16 CONSTANT
 475 CREATE , ,  \ compile Qhi then Qlo
 476 DOES>       \ execution part    addr -- Qhi Qlo
 477 HI2LO
 478 SUB #2,PSP
 479 MOV 2(TOS),0(PSP)
 480 MOV @TOS,TOS
 481 MOV @RSP+,IP
 482 NEXT
 483 ENDCODE
 484 [THEN]
 485
 486 ECHO
 487
 488 ; -----------------------
 489 ; (volatile) tests for FIXPOINT.asm | FIXPOINT.f
 490 ; -----------------------
 491
 492 3,14159 2CONSTANT PI
 493 PI U. U.
 494 PI F.
 495
 496 PI -1,0 F* 2CONSTANT -PI
 497 -PI . U.
 498 -PI F.
 499
 500 $10 BASEADR !  PI F.
 501             -PI F.
 502 %10 BASEADR !  PI F.
 503             -PI F.
 504 #10 BASEADR !  PI F.
 505             -PI F.
 506
 507 PI 2,0 F* F.
 508 PI -2,0 F* F.
 509 -PI 2,0 F* F.
 510 -PI -2,0 F* F.
 511
 512 PI 2,0 F/ F.
 513 PI -2,0 F/ F.
 514 -PI 2,0 F/ F.
 515 -PI -2,0 F/ F.
 516
 517 32767,99999 1,0 F* F.
 518 32767,99999 1,0 F/ F.
 519 32767,99999 2,0 F/ F.
 520 32767,99999 4,0 F/ F.
 521 32767,99999 8,0 F/ F.
 522 32767,99999 16,0 F/ F.
 523
 524 -32767,0 -1,0 F* F.
 525 -32767,0 -1,0 F/ F.
 526 -32767,0 -2,0 F/ F.
 527 -32767,0 -4,0 F/ F.
 528 -32767,0 -8,0 F/ F.
 529 -32767,0 -16,0 F/ F.
 530 -32767,0 -32,0 F/ F.
 531 -32767,0 -64,0 F/ F.
 532
 533 ; SQRT(32768)^2 = 32768
 534 181,01933598375 181,01933598375 F* F.
 535 181,01933598375 -181,01933598375 F* F.
 536 -181,01933598375 181,01933598375 F* F.
 537 -181,01933598375 -181,01933598375 F* F.
 538
 539