forthMSP430FR.asm

   1 ;
   2 ;-------------------------------------------------------------------------------
   3 ; Vingt fois sur le métier remettez votre ouvrage,
   4 ; Polissez-le sans cesse, et le repolissez,
   5 ; Ajoutez quelquefois, et souvent effacez.               Boileau, L'Art poétique
   6 ;-------------------------------------------------------------------------------
   7
   8 ;-------------------------------------------------------------------------------
   9 ; SCITE editor: copy https://www.scintilla.org/Sc4xx.exe to \prog\scite.exe
  10 ;-------------------------------------------------------------------------------
  11 ; MACRO ASSEMBLER AS
  12 ; unzip http://john.ccac.rwth-aachen.de:8000/ftp/as/precompiled/i386-unknown-win32/aswcurr.zip
  13 ;-------------------------------------------------------------------------------
  14     .listing purecode   ; reduce listing to true conditionnal parts
  15     MACEXP_DFT noif     ; reduce macros listing to true part
  16     .PAGE  0            ; listing without pagination
  17 ;-------------------------------------------------------------------------------
  18
  19 VER .equ "V309"     ; FORTH version
  20
  21 ;===============================================================================
  22 ; before assembling or programming you must set TARGET in scite param1 (SHIFT+F8)
  23 ; according to the selected (uncommented) TARGET below
  24 ;===============================================================================
  25 ;    TARGET        ;
  26 ;MSP_EXP430FR5739  ; compile for MSP-EXP430FR5739 launchpad
  27 ;MSP_EXP430FR5969  ; compile for MSP-EXP430FR5969 launchpad
  28 MSP_EXP430FR5994  ;; compile for MSP-EXP430FR5994 launchpad
  29 ;MSP_EXP430FR6989  ; compile for MSP-EXP430FR6989 launchpad
  30 ;MSP_EXP430FR4133  ; compile for MSP-EXP430FR4133 launchpad
  31 ;MSP_EXP430FR2355  ; compile for MSP-EXP430FR2355 launchpad
  32 ;MSP_EXP430FR2433  ; compile for MSP-EXP430FR2433 launchpad
  33 ;LP_MSP430FR2476   ; compile for LP_MSP430FR2476  launchpad
  34 ;CHIPSTICK_FR2433  ; compile for "CHIPSTICK" of M. Ken BOAK
  35
  36 ; choose DTC model (Direct Threaded Code); if you don't know, choose 2, because DOCOL routine without using scratch register
  37 DTC .equ 2  ; DTC model 1 : DOCOL = CALL rDOCOL           14 cycles 1 word      shortest DTC model
  38             ; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT   13 cycles 2 words     best compromize to mix FORTH/ASM code
  39             ; DTC model 3 : inlined DOCOL                  9 cycles 4 words     fastest
  40
  41 THREADS     .equ 16 ;  1,  2 ,  4 ,  8 ,  16,  32  search entries in word-set.
  42                     ; +0, +28, +48, +56, +90, +154 bytes, usefull to speed up compilation;
  43                     ; the FORTH interpreter is speed up by about a square root factor of THREADS.
  44
  45 FREQUENCY   .equ 1 ; fully tested at 1,2,4,8,16 MHz, plus 24 MHz for MSP430FR57xx,MSP430FR2355
  46
  47 ;   ============================================================================
  48 ;TERMINAL_I2C ; - 12 bytes; uncomment to select I2C_Master TERMINAL instead of UART TERMINAL
  49 ;   ============================================================================
  50     .IFDEF TERMINAL_I2C
  51 MYSLAVEADR   .equ 18
  52 ;   ============================================================================
  53     .ELSE ; UART TERMINAL
  54 ;   ============================================================================
  55 TERMINALBAUDRATE    .equ 115200 ; choose value considering the frequency, see explanations below.
  56 ;   ----------------------------------------------------------------------------
  57 TERMINAL3WIRES   ;   ; + 18 bytes  enable 3 wires XON/XOFF software flow control
  58 TERMINAL4WIRES   ;   ; + 12 bytes  enable 4 wires RTS hardware flow control
  59 ;TERMINAL5WIRES      ; + 10 bytes  enable 5 wires RTS/CTS hardware flow control
  60 ;   ----------------------------------------------------------------------------
  61 ;HALFDUPLEX          ; switch to UART half duplex TERMINAL input
  62 ;   ============================================================================
  63     .ENDIF
  64
  65 ;===============================================================================
  66 ; KERNEL ADDONs that can't be added later
  67 ;===============================================================================
  68 DOUBLE_INPUT        ;; +   60 bytes : adds the interpretation engine for double numbers (numbers with dot)
  69 FIXPOINT_INPUT      ;; +   68 bytes : adds the interpretation engine for Q15.16 numbers (numbers with comma)
  70 SD_CARD_LOADER      ; + 1766 bytes : to load source files from SD_card
  71 BOOTLOADER          ; +  132 bytes : includes in WARM process the bootloader SD_CARD\BOOT.4TH.
  72 SD_CARD_READ_WRITE  ; + 1148 bytes : to read, create, write and del files + copy text files from PC to target SD_Card
  73 ;EXTENDED_MEM        ; +  506 bytes : allows assembler to execute code up to 1MB (LARGE_CODE).
  74 ;EXTENDED_ASM        ; + 1212 bytes : extended assembler to 20 bits datas (LARGE_DATA + LARGE_CODE).
  75 ;VOCABULARY_SET      ; +  162 bytes : adds words: WORDSET FORTH hidden PREVIOUS ONLY DEFINITIONS
  76 ;PROMPT              ; +   18 bytes : to display prompt "ok ", for FORTH addicts.
  77 ;===============================================================================
  78     .save
  79     .listing off
  80 ;===============================================================================
  81 ; Software control flow XON/XOFF configuration:
  82 ;===============================================================================
  83 ; Launchpad <-> UARTtoUSB device <-> TeraTerm TERMINAL
  84 ;        RX <-- TX
  85 ;        TX --> RX
  86 ;       GND <-> GND
  87 ;
  88 ; TERATERM config terminal:     NewLine receive : LF,
  89 ;                               NewLine transmit : CR+LF
  90 ;                               Size : 96 chars x 49 lines (adjust lines according to your display)
  91 ;
  92 ; TERATERM config serial port:  TERMINALBAUDRATE value,
  93 ;                               8 bits, no parity, 1 Stop bit,
  94 ;                               XON/XOFF flow control,
  95 ;                               delay = 0ms/line, 0ms/char
  96 ;
  97 ; don't forget to save always new TERATERM configuration !
  98
  99 ; ------------------------------------------------------------------------------
 100 ; Only two usb2uart bridges correctly handle XON / XOFF: cp2102 and pl2303.
 101 ; ------------------------------------------------------------------------------
 102 ; the best and cheapest: UARTtoUSB cable with Prolific PL2303HXD (or PL2303TA)
 103 ; works well in 3 WIRES (XON/XOFF) and 4WIRES (GND,RX,TX,RTS) config
 104 ; ------------------------------------------------------------------------------
 105 ;       PL2303TA 4 wires CABLE                         PL2303HXD 6 wires CABLE
 106 ; pads upside: 3V3,txd,rxd,gnd,5V               pads upside: gnd, 3V3,txd,rxd,5V
 107 ;    downside: cts,dcd,dsr,rts,dtr                 downside:     rts,cts
 108 ; ------------------------------------------------------------------------------
 109 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
 110 ; ------------------------------------------------------------------------------
 111 ; up to 115200  Bds  (500kHz)
 112 ; up to 230400  Bds  (1MHz)
 113 ; up to 460800  Bds  (2MHz)
 114 ; up to 921600  Bds  (4MHz)
 115 ; up to 1843200 Bds  (8MHz)
 116 ; up to 3 MBds       (12MHz,PL2303HXD with shortened cable < 80cm)
 117 ; up to 4 MBds       (16MHz,PL2303HXD with shortened cable < 60cm)
 118 ; up to 5 MBds       (20MHz,PL2303HXD with shortened cable < 40cm)
 119 ; up to 6 MBds       (24MHz,PL2303HXD with shortened cable < 20cm)
 120
 121 ; UARTtoUSB module with Silabs CP2102 (supply current = 20 mA)
 122 ; ------------------------------------------------------------------------------
 123 ; WARNING ! if you use it as supply, buy a CP2102 module with a VCC switch 5V/3V3 and swith on 3V3 !
 124 ; ------------------------------------------------------------------------------
 125 ; 9600,19200,38400 (250kHz)
 126 ; + 57600, 115200 (500kHz)
 127 ; + 134400,230400 (1MHz)
 128 ; + 460800 (2MHz)
 129 ; + 921600 (4MHz,8MHz,16MHz,24MHz)
 130
 131 ;===============================================================================
 132 ; Hardware control flow configuration: RTS is wired on UART2USB CTS pin
 133 ;===============================================================================
 134
 135 ; Launchpad <-> UARTtoUSB
 136 ;        RX <-- TX
 137 ;        TX --> RX
 138 ;       RTS --> CTS     (see launchpad.asm for RTS selected pin)
 139 ;       GND <-> GND
 140
 141 ; RTS pin may be permanently wired on SBWTCK/TEST pin without disturbing SBW 2 wires programming
 142
 143 ; TERATERM config terminal      : NewLine receive : LF,
 144 ;                                 NewLine transmit : CR+LF
 145 ;                                 Size : 96 chars x 49 lines (adjust lines to your display)
 146
 147 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 148 ;                                 8bits, no parity, 1Stopbit,
 149 ;                                 Hardware flow control,
 150 ;                                 delay = 0ms/line, 0ms/char
 151
 152 ; don't forget : save new TERATERM configuration !
 153
 154 ; notice that the control flow seems not necessary for TX (CTS <-- RTS)
 155
 156 ; UARTtoUSB module with PL2303TA/HXD
 157 ; ------------------------------------------------------------------------------
 158 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
 159 ; ------------------------------------------------------------------------------
 160 ; up to 250 kbds / MHz
 161 ; ----------------------------------
 162 ; 9600,19200,38400,57600    (250kHz)
 163 ; + 115200                  (500kHz)
 164 ; + 201600,230400,250000    (1MHz)
 165 ; + 403200,460800           (2MHz)
 166 ; + 806400,921600           (4MHz)
 167 ; + 1843200                 (8MHz)
 168 ; + 2764800                 (12MHz)
 169 ; + 4000000                 (16MHz)
 170 ; + 5000000                 (20MHz)
 171 ; + 6000000                 (24MHz)
 172
 173 ; UARTtoUSB module with FTDI FT232RL (FT230X don't work correctly)
 174 ; ------------------------------------------------------------------------------
 175 ; WARNING ! buy a FT232RL module with a switch 5V/3V3 and select 3V3 !
 176 ; ------------------------------------------------------------------------------
 177 ; 9600,19200,38400,57600,115200 (500kHz)
 178 ; + 230400 (1MHz)
 179 ; + 460800 (2MHz)
 180 ; + 921600 (4,8,16 MHz)
 181
 182 ; ------------------------------------------------------------------------------
 183 ; UARTtoBluetooth 2.0 module (RN42 sparkfun bluesmirf) at 921600bds
 184 ; ------------------------------------------------------------------------------
 185 ; 9600,19200,38400,57600,115200 (500kHz)
 186 ; + 230400 (1MHz)
 187 ; + 460800 (2MHz)
 188 ; + 921600 (4,8,16 MHz)
 189
 190 ; RN42 config : connect RN41/RN42 module on teraterm, via USBtoUART bridge,
 191 ; -----------   8n1, 115200 bds, no flow control, echo on
 192 ;               $$$         // enter control mode, response: AOK
 193 ;               SU,92       // set 921600 bds, response: AOK
 194 ;               R,1         // reset module to take effect
 195 ;
 196 ;               connect RN42 module on FastForth target
 197 ;               add new bluetooth device on windows, password=1234
 198 ;               open the created output COMx port with TERATERM at 921600bds
 199
 200
 201 ; TERATERM config terminal      : NewLine receive : LF,
 202 ;                                 NewLine transmit : CR+LF
 203 ;                                 Size : 80 chars x 44 lines (adjust lines to your display)
 204
 205 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 206 ;                                 8bits, no parity, 1Stopbit,
 207 ;                                 Hardware flow control or software flow control or ...no flow control!
 208 ;                                 delay = 0ms/line, 0ms/char
 209
 210 ; don't forget : save new TERATERM configuration !
 211
 212 ; in fact, compared to using a UART USB bridge, only the COMx port is to be updated.
 213     .restore
 214 ; ------------------------------------------------------------------------------
 215     .include "ThingsInFirst.inc" ; macros, target definitions, RAM & INFO variables...
 216 ;-------------------------------------------------------------------------------
 217     .org    MAIN_ORG
 218 ;-------------------------------------------------------------------------------
 219 ; DTCforthMSP430FR5xxx program (FRAM) memory
 220 ;-------------------------------------------------------------------------------
 221 ; here we place the FORTH primitives without name.
 222 ; Users can access them via declarations made in \inc\MSP430FRxxxx.pat
 223 ;
 224 ;###############################################################################
 225 ; here, FAST FORTH sleeps, waiting any interrupt. With LPM4, supply current is below 1uA.
 226 ; IP,S,T,W,X,Y registers (R13 to R8) are free...
 227 ; ...and so TOS, PSP and RSP stacks within their rules of use.
 228 ;
 229 ; ; remember: to force SLEEP execution, you must end any interrupt routine with :
 230 ; ;               BIC #%0_1111_000,0(RSP) ; 4~
 231 ; ;               RETI                    ; 5~    4 words
 232 ; ;
 233 ; remember: to force SLEEP execution, you must end any interrupt routine with :
 234 ;               MOV @RSP+,SR        ; 2~
 235 ;               BIC #%0_1111_000,SR ; 2~
 236 ;               RET                 ; 3~    4 words
 237 ;
 238 ;           or faster (but SR flags will be lost):
 239 ;               ADD #2 RSP          ; 1~
 240 ;               RET                 ; 3~    2 words
 241 ;
 242 SLEEP       CALL &SLEEP_APP     ;   BACKGND_DEF = UART_RXON/I2C_ACCEPT as default BACKGND_APP; value set by DEEP.
 243             BIS &LPM_MODE,SR    ;2  enter in LPMx mode with GIE=1
 244             JMP SLEEP           ;2  return off any interrupts else TERMINAL_INT
 245 ;
 246 ;###############################################################################
 247
 248 ; ------------------------------------------------------------------------------
 249 ; COMPILING OPERATORS
 250 ; ------------------------------------------------------------------------------
 251 ; Primitive lit; compiled by LITERAL
 252 ; lit      -- x    fetch inline literal to stack
 253 ; This is the run-time code of LITERAL.
 254 lit         SUB #2,PSP          ; 1  save old TOS..
 255             MOV TOS,0(PSP)      ; 3  ..onto stack
 256             MOV @IP+,TOS        ; 2  fetch new TOS value
 257             MOV @IP+,PC         ; 4  NEXT
 258
 259 TWODUP_XSQUOTE                  ; used by [ELSE]
 260             MOV TOS,-2(PSP)     ; 3
 261             MOV @PSP,-4(PSP)    ; 4
 262             SUB #4,PSP          ; 1
 263 ; Primitive XSQUOTE; compiled by SQUOTE
 264 ; (S")     -- addr u   run-time code to get address and length of a compiled string.
 265 XSQUOTE     SUB #4,PSP          ; 1                 push old TOS on stack
 266             MOV TOS,2(PSP)      ; 3                 and reserve one cell on stack
 267             MOV.B @IP+,TOS      ; 2 -- ? u          u = lenght of string
 268             MOV IP,0(PSP)       ; 3 -- addr u       IP is odd...
 269             ADD TOS,IP          ; 1 -- addr u       IP=addr+u=addr(end_of_string)
 270             BIT #1,IP           ; 1 -- addr u       IP=addr+u   Carry set/clear if odd/even
 271             ADDC #0,IP          ; 1 -- addr u       IP=addr+u aligned
 272             MOV @IP+,PC         ; 4  16~
 273
 274 ; https://forth-standard.org/standard/core/HERE
 275 ; HERE    -- addr      returns memory program ptr
 276 HEREXEC     SUB #2,PSP
 277             MOV TOS,0(PSP)
 278             MOV &DP,TOS
 279             MOV @IP+,PC
 280
 281 ; primitive MU/MOD; used by ?NUMBER UM/MOD, and M*/ in DOUBLE word set
 282 ; MU/MOD    UDVDlo UDVDhi UDIVlo -- UREMlo UQUOTlo UQUOThi
 283 ;-------------------------------------------------------------------------------
 284 ; unsigned 32-BIT DiViDend : 16-BIT DIVisor --> 32-BIT QUOTient 16-BIT REMainder
 285 ;-------------------------------------------------------------------------------
 286 ; two times faster if 16 bits DiViDend (cases of U. and . among others)
 287
 288 ; reg     division            MU/MOD      NUM                       M*/
 289 ; ---------------------------------------------------------------------
 290 ; S     = DVD(15-0)         = ud1lo     = ud1lo                     ud1lo
 291 ; TOS   = DVD(31-16)        = ud1hi     = ud1hi                     ud1mi
 292 ; W     = DVD(47-32)/REM    = rem       = digit --> char --> -[HP]  ud1hi
 293 ; T     = DIV(15-0)         = BASE      = BASE                      ud2
 294 ; X     = QUOTlo            = ud2lo     = ud2lo                     QUOTlo
 295 ; Y     = QUOThi            = ud2hi     = ud2hi                     QUOThi
 296 ; rDODOES = count
 297
 298 MUSMOD      MOV TOS,T               ;1 T = DIVlo
 299             MOV 2(PSP),S            ;3 S = DVDlo
 300             MOV @PSP,TOS            ;2 TOS = DVDhi
 301 MUSMOD1     MOV #0,W                ;1  W = REMlo = 0
 302             MOV #32,rDODOES         ;2  init loop count
 303             CMP #0,TOS              ;1  DVDhi=0 ?
 304             JNZ MDIV1               ;2  no
 305 ; ----------------------------------;
 306 MDIV1DIV2   RRA rDODOES             ;1  yes:loop count / 2
 307             MOV S,TOS               ;1      DVDhi <-- DVDlo
 308             MOV #0,S                ;1      DVDlo <-- 0
 309             MOV #0,X                ;1      QUOTlo <-- 0 (to do QUOThi = 0 at the end of division)
 310 ; ----------------------------------;
 311 MDIV1       CMP T,W                 ;1  REMlo U>= DIVlo ?
 312             JNC MDIV2               ;2  no : carry is reset
 313             SUB T,W                 ;1  yes: REMlo - DIVlo ; carry is set
 314 MDIV2       ADDC X,X                ;1  RLC quotLO
 315             ADDC Y,Y                ;1  RLC quotHI
 316             SUB #1,rDODOES          ;1  Decrement loop counter
 317             JN ENDMDIV              ;2
 318             ADD S,S                 ;1  RLA DVDlo
 319             ADDC TOS,TOS            ;1  RLC DVDhi
 320             ADDC W,W                ;1  RLC REMlo
 321             JNC MDIV1               ;2
 322             SUB T,W                 ;1  REMlo - DIVlo
 323             BIS #1,SR               ;1  SETC
 324             JMP MDIV2               ;2
 325 ENDMDIV     MOV #XDODOES,rDODOES    ;2  restore rDODOES
 326             MOV W,2(PSP)            ;3  REMlo in 2(PSP)
 327             MOV X,0(PSP)            ;3  QUOTlo in 0(PSP)
 328             MOV Y,TOS               ;1  QUOThi in TOS
 329 RET_ADR     MOV @RSP+,PC            ;4  35 words, about 466/246 cycles, not FORTH executable !
 330
 331 ; : SETIB SOURCE 2! 0 >IN ! ;
 332 ; SETIB      org len --        set Input Buffer, shared by INTERPRET and [ELSE]
 333 SETIB       MOV TOS,&SOURCE_LEN     ; -- org len
 334             MOV @PSP+,&SOURCE_ORG   ; -- len
 335             MOV #0,&TOIN            ;
 336 DROP        MOV @PSP+,TOS           ; --
 337             MOV @IP+,PC             ;
 338
 339 ; REFILL    accept one line to input buffer and leave org len' of the filled input buffer
 340 ; as it has no more host OS and as waiting command is done by ACCEPT, REFILL's flag is useless
 341 ; : REFILL TIB DUP CIB_LEN ACCEPT   ;   -- org len'     shared by QUIT and [ELSE]
 342 REFILL      SUB #4,PSP              ;1
 343             MOV TOS,2(PSP)          ;3                  save TOS
 344 TWODROP_REFILL                      ;                   see [ELSE]
 345             MOV #CIB_LEN,TOS        ;2  -- x len        Current Input Buffer LENght
 346             .word 40BFh             ;                   MOV #imm,index(PSP)
 347 CIB_ORG     .word TIB_ORG           ;                   imm=TIB_ORG
 348             .word 0                 ;4  -- org len      index=0 ==> MOV #TIB_ORG,0(PSP)
 349             MOV @PSP,-2(PSP)        ;4  -- org len
 350             SUB #2,PSP              ;1  -- org org len
 351             JMP ACCEPT              ;2  org org len -- org len'
 352
 353 ; Primitive QFBRAN; compiled by IF UNTIL
 354 ;Z ?FalseBranch   x --              ; branch if TOS is FALSE (TOS = 0)
 355 QFBRAN      CMP #0,TOS              ; 1  test TOS value
 356             MOV @PSP+,TOS           ; 2  pop new TOS value (doesn't change flags)
 357 ZBRAN       JNZ SKIPBRANCH          ; 2  if TOS was <> 0, skip the branch; 10 cycles
 358 BRAN        MOV @IP,IP              ; 2  take the branch destination
 359             MOV @IP+,PC             ; 4  ==> branch taken, 11 cycles
 360
 361 XDODOES                             ; 4 for CALL rDODOES
 362             SUB #2,PSP              ;+1
 363             MOV TOS,0(PSP)          ;+3 save TOS on parameters stack
 364             MOV @RSP+,TOS           ;+2 TOS = PFA address of master word, i.e. address of its first cell after DOES>
 365             PUSH IP                 ;+3 save IP on return stack
 366             MOV @TOS+,IP            ;+2 IP = CFA of Master word, TOS = BODY address of created word
 367             MOV @IP+,PC             ;+4 = 19~ = ITC-2
 368
 369 XDOCON                              ; 4 for CALL rDOCON
 370             SUB #2,PSP              ;+1
 371             MOV TOS,0(PSP)          ;+3 save TOS on parameters stack
 372             MOV @RSP+,TOS           ;+2 TOS = PFA address of master word CONSTANT
 373             MOV @TOS,TOS            ;+2 TOS = CONSTANT value
 374             MOV @IP+,PC             ;+4 = 16~ = ITC+4
 375
 376 ;-----------------------------------;
 377 INIT_FORTH                          ; common part of QABORT|WARM|PUC
 378 ;-----------------------------------;
 379             CALL &SOFT_APP          ; init SOFT_APP
 380             MOV @RSP+,IP            ; init IP with CALLER next address
 381 ;                                   ;
 382             MOV #PUC_ABORT_ORG,X    ; FRAM INFO         FRAM MAIN
 383 ;                                   ; ---------         ---------
 384             MOV @X+,&PFAACCEPT      ; BODYACCEPT    --> PFAACCEPT
 385             MOV @X+,&PFAEMIT        ; BODYEMIT      --> PFAEMIT
 386             MOV @X+,&PFAKEY         ; BODYKEY       --> PFAKEY
 387             MOV @X+,&CIB_ORG        ; TIB_ORG       --> CIB_ORG
 388 ;                                   ;
 389 ;                                   ; FRAM INFO         REG|RAM
 390 ;                                   ; ---------         -------
 391             MOV @X+,RSP             ; INIT_RSTACK   --> R1=RSP
 392             MOV @X+,rDOCOL          ; INIT_DTC      --> R4=rDOCOL
 393             MOV @X+,rDODOES         ; INIT_DODOES   --> R5=rDODOES
 394             MOV @X+,rDOCON          ; INIT_DOCON    --> R6=rDOCON
 395             MOV @X+,rDOVAR          ; INIT_RFROM    --> R7=rDOVAR
 396             MOV @X+,&CAPS           ; INIT_CAPS     --> RAM CAPS            init CAPS ON
 397             MOV @X+,&BASEADR        ; INIT_BASE     --> RAM BASE            init decimal base
 398             MOV @X+,&LEAVEPTR       ; INIT_LEAVE    --> RAM LEAVEPTR
 399             MOV #0,&STATE           ; 0             --> RAM STATE
 400             MOV #SEL_RST_DEP,PC     ; goto PUC 7 to select the user's choice from TOS value:    RST_RET|DEEP_RESET
 401 ;-----------------------------------;
 402
 403     .IFDEF TERMINAL_I2C
 404         .include "forthMSP430FR_TERM_I2C.asm"
 405     .ELSE
 406         .IFDEF HALFDUPLEX
 407             .include "forthMSP430FR_TERM_HALF.asm"
 408         .ELSE
 409             .include "forthMSP430FR_TERM_UART.asm"
 410         .ENDIF
 411     .ENDIF
 412     .IFDEF SD_CARD_LOADER
 413         .include "forthMSP430FR_SD_ACCEPT.asm"
 414     .ENDIF
 415
 416     .IF DTC = 1                     ; DOCOL = CALL rDOCOL, [rDOCOL] = XDOCOL
 417 XDOCOL      MOV @RSP+,W             ; 2
 418             PUSH IP                 ; 3     save old IP on return stack
 419             MOV W,IP                ; 1     set new IP to PFA
 420             MOV @IP+,PC             ; 4     = NEXT
 421     .ENDIF                          ; 10 cycles
 422
 423             FORTHWORD "TYPE"
 424 ;https://forth-standard.org/standard/core/TYPE
 425 ;C TYPE    adr u --     type string to terminal
 426 TYPE        PUSH IP                 ;3
 427             MOV #TYPE_NEXT,IP       ;2
 428 ;            PUSHM #2,X              ;4                 push X Y
 429             MOV @PSP,X              ;2 -- adr len       X = adr
 430 TYPELOOP    MOV TOS,0(PSP)          ;3 -- len len
 431             MOV.B @X+,TOS           ;2 -- len char
 432             JMP EMIT                ;2                  ~17, S T W regs are free
 433 TYPE_NEXT   mNEXTADR                ;  -- len
 434             SUB #2,IP               ;1                  [IP] = TYPE_NEXT
 435             SUB #2,PSP              ;1 -- x len
 436             SUB.B #1,TOS            ;1 -- x len-1       byte operation, according to the /COUNTED-STRING value
 437             JNZ TYPELOOP            ;2                  29~ EMIT loop
 438 ;            POPM #2,X               ;4                   pop Y X
 439             MOV @RSP+,IP            ;2 -- x 0
 440 TWODROP     ADD #2,PSP              ;1 -- 0
 441             MOV @PSP+,TOS           ;2 --
 442             MOV @IP+,PC             ;4
 443
 444 BL          CALL rDOCON
 445             .word   20h
 446
 447 ; ------------------------------------------------------------------------------
 448 ; forthMSP430FR :  CONDITIONNAL COMPILATION, 114/109 words
 449 ; ------------------------------------------------------------------------------
 450 ; BRanch if BAD strings COMParaison, [COMPARE ZEROEQUAL QFBRAN] replacement
 451 BRBADCOMP                   ; -- addr1 u1 addr2 u2
 452             MOV TOS,S       ;1          S = u2
 453             MOV @PSP+,Y     ;2          Y = addr2
 454             CMP @PSP+,S     ;2          u1 = u2 ?
 455             MOV @PSP+,X     ;2          X = addr1
 456             MOV @PSP+,TOS   ;2 --
 457             JNZ BRAN        ;2 --       branch if u1<>u2, 11+6 cycles
 458 COMPLOOP    CMP.B @Y+,0(X)  ;4
 459             JNZ BRAN        ;2 --       if char1<>char2; branch on first char <> in 17+6 cycles
 460             ADD #1,X        ;1          addr1+1
 461             SUB #1,S        ;1          u2-1
 462             JNZ COMPLOOP    ;2          10 cycles char comp loop
 463 SKIPBRANCH  ADD #2,IP       ;1
 464             MOV @IP+,PC     ;4
 465
 466 ; [TWODROP ONEMINUS ?DUP ZEROEQUAL QFBRAN next_comp EXIT] replacement
 467 BRNEXTCMP                   ;    -- cnt addr u
 468             ADD #2,PSP      ;1   -- cnt addr    TWODROP
 469             MOV @PSP+,TOS   ;2   -- cnt
 470             SUB #1,TOS      ;3   -- cnt-1       ONEMINUS
 471             JNZ BRAN        ;2   -- cnt-1       branch to next comparaison if <> 0
 472             JZ DROPEXIT     ;19w                else DROP EXIT
 473
 474             FORTHWORDIMM  "[ELSE]"
 475 ; https://forth-standard.org/standard/tools/BracketELSE
 476 ; [ELSE]      a small and fast definition
 477 ;Compilation:
 478 ;Perform the execution semantics given below.
 479 ;Execution:
 480 ;( "<spaces>name ..." -- )
 481 ;Skipping leading spaces, parse and discard space-delimited words from the parse area,
 482 ;including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN],
 483 ;until the word [THEN] has been parsed and discarded.
 484 ;If the parse area becomes exhausted, it is refilled as with REFILL.
 485 BRACKETELSE
 486             mDOCOL
 487             .word   lit,0                   ; -- 0
 488 BRACKETELSE0
 489             .word   ONEPLUS                 ; -- cnt+1
 490 BRACKETELSE1                                ;
 491             .word   BL,WORDD,COUNT          ; -- cnt addr u   Z=1 if U=0
 492             .word   ZBRAN,BRACKETELSE5      ;       u = 0 if end of line --> refill buffer then loop back
 493             .word   TWODUP_XSQUOTE          ;    oui je sais, c'est pas beau mais c'est efficace....
 494             .byte   6,"[THEN]"              ; -- cnt addr u addr u addr2 u2
 495             .word   BRBADCOMP,BRACKETELSE2  ; -- cnt addr u      if bad string comparaison, jump for next comparaison
 496             .word   BRNEXTCMP,BRACKETELSE1  ; 2DROP,  count-1, loop back if count <> 0, else DROP EXIT
 497 BRACKETELSE2                                ;
 498             .word   TWODUP_XSQUOTE          ;
 499             .byte   6,"[ELSE]"              ;
 500             .word   BRBADCOMP,BRACKETELSE3  ; if bad string comparaison, jump for next comparaison
 501             .word   BRNEXTCMP,BRACKETELSE0  ; 2DROP, count-1, loop back with count+1 if count <> 0, else DROP EXIT
 502 BRACKETELSE3                                ;
 503             .word   XSQUOTE                 ;
 504             .byte   4,"[IF]"                ;
 505             .word   BRBADCOMP,BRACKETELSE1  ; if bad string comparaison, loop back
 506             .word   BRAN,BRACKETELSE0       ; else loop back with count+1
 507 BRACKETELSE5                                ;
 508 ;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;
 509 ; OPTION                                    ; +5 words option
 510 ;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;
 511             .word   XSQUOTE                 ;
 512             .byte   5,13,"ko ",10           ;
 513             .word   TYPE                    ; CR ." ko " LF     to show false branch of conditionnal compilation
 514 ;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;
 515             .word   TWODROP_REFILL          ; REFILL Input Buffer with next line
 516             .word   SETIB                   ; SET Input Buffer pointers SOURCE_LEN, SOURCE_ORG and clear >IN
 517             .word   BRAN,BRACKETELSE1       ; then loop back   45/40 words with/without option
 518
 519             FORTHWORDIMM "[THEN]"   ; do nothing
 520 ; https://forth-standard.org/standard/tools/BracketTHEN
 521 ; [THEN]
 522 BRACKETTHEN  MOV @IP+,PC
 523
 524             FORTHWORDIMM "[IF]" ; flag --
 525 ; https://forth-standard.org/standard/tools/BracketIF
 526 ; [IF]
 527 ;Compilation:
 528 ;Perform the execution semantics given below.
 529 ;Execution: ;( flag | flag "<spaces>name ..." -- )
 530 ;If flag is true, do nothing. Otherwise, skipping leading spaces,
 531 ;   parse and discard space-delimited words from the parse area,
 532 ;   including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN],
 533 ;   until either the word [ELSE] or the word [THEN] has been parsed and discarded.
 534 ;If the parse area becomes exhausted, it is refilled as with REFILL. [IF] is an immediate word.
 535 ;An ambiguous condition exists if [IF] is POSTPONEd,
 536 ;   or if the end of the input buffer is reached and cannot be refilled before the terminating [ELSE] or [THEN] is parsed.
 537 BRACKETIF   CMP #0,TOS      ; -- f
 538             MOV @PSP+,TOS   ; --
 539             JZ BRACKETELSE  ;       if false flag output
 540             MOV @IP+,PC     ;       if true flag output
 541
 542             FORTHWORDIMM  "[DEFINED]"
 543 ; https://forth-standard.org/standard/tools/BracketDEFINED
 544 ; [DEFINED]
 545 ;Compilation:
 546 ;Perform the execution semantics given below.
 547 ;Execution:
 548 ;( "<spaces>name ..." -- flag )
 549 ;Skip leading space delimiters. Parse name delimited by a space.
 550 ;Return a true flag if name is the name of a word that can be found,
 551 ;otherwise return a false flag. [DEFINED] is an immediate word.
 552 DEFINED     mDOCOL
 553             .word   BL,WORDD,FIND
 554             .word   NIP,EXIT
 555
 556
 557             FORTHWORDIMM  "[UNDEFINED]"
 558 ; https://forth-standard.org/standard/tools/BracketUNDEFINED
 559 ; [UNDEFINED]
 560 ;Compilation:
 561 ;Perform the execution semantics given below.
 562 ;Execution: ( "<spaces>name ..." -- flag )
 563 ;Skip leading space delimiters. Parse name delimited by a space.
 564 ;Return a false flag if name is the name of a word that can be found,
 565 ;otherwise return a true flag.
 566             mDOCOL
 567             .word   BL,WORDD,FIND
 568             mNEXTADR
 569             MOV @RSP+,IP
 570             ADD #2,PSP      ; NIP
 571 ; https://forth-standard.org/standard/core/ZeroEqual
 572 ; 0=     n/u -- flag    return true if TOS=0
 573 ZEROEQUAL   SUB #1,TOS      ;1 borrow (clear cy) if TOS was 0
 574             SUBC TOS,TOS    ;1 TOS=-1 if borrow was set
 575             MOV @IP+,PC     ;4
 576
 577 ;-------------------------------------------------------------------------------
 578 ; STACK OPERATIONS
 579 ;-------------------------------------------------------------------------------
 580 ; https://forth-standard.org/standard/core/SWAP
 581 SWAP        PUSH @PSP+      ; 3
 582
 583 ; https://forth-standard.org/standard/core/Rfrom
 584 ; R>    -- x    R: x --   pop from return stack
 585 ; VARIABLE run time called by CALL rDOVAR
 586 RFROM       SUB #2,PSP      ; 1
 587             MOV TOS,0(PSP)  ; 3
 588             MOV @RSP+,TOS   ; 2
 589             MOV @IP+,PC     ; 4
 590
 591 ; https://forth-standard.org/standard/core/DUP
 592 ; DUP      x -- x x      duplicate top of stack
 593 DUP         MOV TOS,-2(PSP) ; 3
 594 POSTDECR    SUB #2,PSP      ; 1 post decrement stack...
 595             MOV @IP+,PC     ; 4
 596
 597 ; https://forth-standard.org/standard/core/DEPTH
 598 ; DEPTH    -- +n        number of items on stack, must leave 0 if stack empty
 599 DEPTH       MOV TOS,-2(PSP)
 600             MOV #PSTACK,TOS
 601             SUB PSP,TOS     ; PSP-S0--> TOS
 602             RRA TOS         ; TOS/2   --> TOS
 603             JMP POSTDECR
 604
 605 ;-------------------------------------------------------------------------------
 606 ; ARITHMETIC OPERATIONS
 607 ;-------------------------------------------------------------------------------
 608 ; https://forth-standard.org/standard/core/Minus
 609 ; -      n1/u1 n2/u2 -- n3/u3      n3 = n1-n2
 610 MINUS       SUB @PSP+,TOS   ;2  -- n2-n1
 611 NEGATE      XOR #-1,TOS     ;1
 612 ONEPLUS     ADD #1,TOS      ;1  -- n3 = -(n2-n1) = n1-n2
 613             MOV @IP+,PC
 614
 615 ;-------------------------------------------------------------------------------
 616 ; MEMORY OPERATIONS
 617 ;-------------------------------------------------------------------------------
 618             FORTHWORD "@"
 619 ; https://forth-standard.org/standard/core/Fetch
 620 ; @       a-addr -- x   fetch cell from memory
 621 FETCH       MOV @TOS,TOS
 622             MOV @IP+,PC
 623
 624             FORTHWORD "!"
 625 ; https://forth-standard.org/standard/core/Store
 626 ; !        x a-addr --   store cell in memory
 627 STORE       MOV @PSP+,0(TOS);4
 628             MOV @PSP+,TOS   ;2
 629             MOV @IP+,PC     ;4
 630
 631 ;-------------------------------------------------------------------------------
 632 ; COMPARAISON OPERATIONS
 633 ;-------------------------------------------------------------------------------
 634 ; https://forth-standard.org/standard/core/Zeroless
 635 ; 0<     n -- flag      true if TOS negative
 636 ZEROLESS    ADD TOS,TOS     ;1 set carry if TOS negative
 637             SUBC TOS,TOS    ;1 TOS=-1 if carry was clear
 638 INVERT      XOR #-1,TOS     ;1 TOS=-1 if carry was set
 639             MOV @IP+,PC     ;
 640
 641 ;            FORTHWORD "U>"
 642 ; https://forth-standard.org/standard/core/Umore
 643 ; U>     n1 n2 -- flag
 644 UMORE       SUB @PSP+,TOS   ;2
 645             JNC UMOREEND    ; 2 flag = true, Z = 0
 646             AND #0,TOS      ; 1 flag = false,Z = 1
 647 UMOREEND    MOV @IP+,PC     ; 4
 648
 649 ; ------------------------------------------------------------------------------
 650 ; STRINGS PROCESSING
 651 ; ------------------------------------------------------------------------------
 652             FORTHWORDIMM "S\34" ; immediate
 653 ; https://forth-standard.org/standard/core/Sq
 654 ; S"       --             compile in-line string
 655 SQUOTE      MOV #0,&CAPS            ; CAPS OFF
 656             mDOCOL
 657             .word   lit,XSQUOTE,COMMA
 658             .word   lit,'"',WORDD   ; -- c-addr = HERE      W=Count_of_chars
 659             mNEXTADR                ;
 660             MOV #20h,&CAPS          ; restore CAPS ON
 661             ADD #1,W                ;
 662             BIT #1,W                ;1          C = /Z
 663             ADDC W,&DP              ;           DP is aligned
 664 DROPEXIT    MOV @PSP+,TOS           ; --
 665             MOV @RSP+,IP
 666             MOV @IP+,PC
 667
 668             FORTHWORDIMM ".\34"     ; immediate
 669 ; https://forth-standard.org/standard/core/Dotq
 670 ; ."       --              compile string to print
 671 DOTQUOTE    mDOCOL
 672             .word   SQUOTE
 673             .word   lit,TYPE,COMMA
 674             .word   EXIT
 675
 676 ;-------------------------------------------------------------------------------
 677 ; NUMERIC OUTPUT
 678 ;-------------------------------------------------------------------------------
 679 ; Numeric conversion is done last digit first, so
 680 ; the output buffer is built backwards in memory.
 681
 682             FORTHWORD "<#"
 683 ; https://forth-standard.org/standard/core/num-start
 684 ; <#    --       begin numeric conversion (initialize Hold Pointer)
 685 LESSNUM     MOV #HOLD_BASE,&HP
 686             MOV @IP+,PC
 687
 688             FORTHWORD "#"
 689 ; https://forth-standard.org/standard/core/num
 690 ; #     ud1lo ud1hi -- ud2lo ud2hi          convert 1 digit of output
 691 NUM         MOV &BASEADR,T          ;3
 692 NUM1        MOV @PSP,S              ;2          -- DVDlo DVDhi              S = DVDlo
 693             SUB #2,PSP              ;1          -- x x DVDhi                TOS = DVDhi
 694             CALL #MUSMOD1           ;244/444    -- REMlo QUOTlo QUOThi      T is unchanged W=REMlo X=QUOTlo Y=QUOThi
 695             MOV @PSP+,0(PSP)        ;4          -- QUOTlo QUOThi            W = REMlo
 696 TODIGIT     CMP.B #10,W             ;2
 697             JNC TODIGIT1            ;2  jump if U<
 698             ADD.B #7,W              ;2
 699 TODIGIT1    ADD.B #30h,W            ;2
 700 HOLDW       SUB #1,&HP              ;3  store W=char --> -[HP]
 701             MOV &HP,Y               ;3
 702             MOV.B W,0(Y)            ;3
 703             MOV @IP+,PC             ;4 22 words, about 276|476 cycles for u|ud one digit
 704
 705             FORTHWORD "#S"
 706 ; https://forth-standard.org/standard/core/numS
 707 ; #S    udlo udhi -- 0 0       convert remaining digits
 708 NUMS        mDOCOL
 709             .word   NUM             ;       X=QUOTlo
 710             mNEXTADR                ;       next adr
 711             SUB #2,IP               ;1      restore NUM return
 712             BIS TOS,X               ;1
 713             CMP #0,X                ;1      ud = 0 ?
 714             JNZ NUM1                ;2
 715 EXIT        MOV @RSP+,IP            ;2      when DTC=2 rDOCOL is loaded with this EXIT address
 716             MOV @IP+,PC             ;4 10 words, about 294|494 cycles for u|ud one digit
 717
 718             FORTHWORD "#>"
 719 ; https://forth-standard.org/standard/core/num-end
 720 ; #>    udlo:udhi -- addr u    end conversion, get string
 721 NUMGREATER  MOV &HP,0(PSP)          ; -- addr 0
 722             MOV #HOLD_BASE,TOS      ;
 723             SUB @PSP,TOS            ; -- addr u
 724             MOV @IP+,PC
 725
 726             FORTHWORD "HOLD"
 727 ; https://forth-standard.org/standard/core/HOLD
 728 ; HOLD  char --        add char to output string
 729 HOLD        MOV.B TOS,W             ;1
 730             MOV @PSP+,TOS           ;2
 731             JMP HOLDW               ;15
 732
 733             FORTHWORD "SIGN"
 734 ; https://forth-standard.org/standard/core/SIGN
 735 ; SIGN  n --           add minus sign if n<0
 736 SIGN        CMP #0,TOS
 737             MOV @PSP+,TOS
 738             MOV.B #'-',W
 739             JN HOLDW                ; jump if 0<
 740             MOV @IP+,PC
 741
 742             FORTHWORD "U."
 743 ; https://forth-standard.org/standard/core/Ud
 744 ; U.    u --           display u (unsigned)
 745 ; note: DDOT = UDOT + 10
 746 ; use enhanced MUSMOD with 16 bits dividend instead of 32.
 747 UDOT        MOV #0,S                ; 1 -- hi=0
 748 DOTTODDOT   SUB #2,PSP              ; 1 convert n|u to d|ud with Y = -1|0
 749             MOV TOS,0(PSP)          ; 3 -- lo lo
 750             MOV S,TOS               ; 1 -- lo hi
 751 DDOT        PUSHM #2,IP             ; 4             R-- IP sign
 752             AND #-1,TOS             ; clear V, set N
 753             JGE DDOTNEXT            ; if hi positive (N=0)
 754             XOR #-1,0(PSP)          ;4
 755             XOR #-1,TOS             ;1
 756             ADD #1,0(PSP)           ;4
 757             ADDC #0,TOS             ;1
 758 DDOTNEXT    mASM2FORTH              ;10
 759             .word   LESSNUM
 760             .word   BL,HOLD         ; add a trailing space
 761             .word   NUMS            ;               R-- IP sign
 762             .word   RFROM,SIGN      ;               R-- IP
 763             .word   NUMGREATER,TYPE
 764             .word   EXIT
 765
 766             FORTHWORD "."
 767 ; https://forth-standard.org/standard/core/d
 768 ; .     n --           display n (signed)
 769 DOT         CMP #0,TOS
 770             JGE UDOT
 771             MOV #-1,S
 772             JMP DOTTODDOT
 773
 774 ;-------------------------------------------------------------------------------
 775 ; INTERPRETER
 776 ;-------------------------------------------------------------------------------
 777             FORTHWORD "WORD"
 778 ; https://forth-standard.org/standard/core/WORD
 779 ; WORD   char -- addr        Z=1 if len=0
 780 ; parse a word delimited by char separator
 781 ; if CAPS is ON, this word is CAPITALIZED unless 'char' input.
 782 ; notice that the average lenght of all CORE definitions is about 4.
 783 WORDD       MOV #SOURCE_LEN,S   ;2 -- sep
 784             MOV @S+,X           ;2              X = src_len
 785             MOV @S+,Y           ;2              Y = src_org
 786             ADD Y,X             ;1              X = src_len + src_org = src_end
 787             ADD @S+,Y           ;2              Y = >IN + src_org = src_ptr
 788             MOV @S,W            ;2              W = HERE = dst_ptr
 789 SKIPCHARLOO CMP Y,X             ;1              src_ptr = src_end ?
 790             JZ SKIPCHAREND      ;2              if yes : End Of Line !
 791             CMP.B @Y+,TOS       ;2              does char = separator ?
 792             JZ SKIPCHARLOO      ;2              if yes; 7~ loop
 793             SUB #1,Y            ;1              decrement the post incremented src_ptr
 794 QSCANTICK   MOV &CAPS,T         ;3              CAPS OFF = 0, CAPS ON = $20.
 795             CMP.B #"'",0(Y)     ;4              first char = TICK ?
 796             JNZ SCANWORDLOO     ;2              no
 797             CMP.B @Y,2(Y)       ;3              third char = TICK ?
 798             JNZ SCANWORDLOO     ;2              no
 799             MOV #0,T            ;1              don't change to upper case for 'char' input
 800 SCANWORDLOO MOV.B S,0(W)        ;3              first, S makes room in dst for word length; next, put char.
 801             CMP Y,X             ;1              src_ptr = src_end ?
 802             JZ SCANWORDEND      ;2              if yes
 803             MOV.B @Y+,S         ;2              S=char
 804             CMP.B S,TOS         ;1 -- sep       does char = separator ?
 805             JZ SCANWORDEND      ;2              if yes
 806             ADD #1,W            ;1              increment dst just before test loop
 807             CMP.B #'a',S        ;2              char U< 'a' ?  this condition is tested at each loop
 808             JNC SCANWORDLOO     ;2              16~ upper case char loop
 809             CMP.B #'z'+1,S      ;2              char U>= 'z'+1 ?
 810             JC SCANWORDLOO      ;2              U>= loopback if yes
 811             SUB.B T,S           ;1              convert a...z to A...Z if CAPS ON (T=$20)
 812             JMP SCANWORDLOO     ;2              23~ lower case char loop
 813 SCANWORDEND
 814 SKIPCHAREND SUB &SOURCE_ORG,Y   ;3 -- sep       Y=src_ptr - src_org = new >IN (first char separator next)
 815             MOV Y,&TOIN         ;3              update >IN
 816             MOV &DP,TOS         ;3 -- c-addr
 817             SUB TOS,W           ;1              W=Word_Length
 818             MOV.B W,0(TOS)      ;3
 819             MOV @IP+,PC         ;4 -- c-addr    48 words      Z=1 <==> lenght=0 <==> EOL, Z is tested by INTERPRET
 820
 821             FORTHWORD "FIND"    ;
 822 ; https://forth-standard.org/standard/core/FIND
 823 ; FIND   c-addr -- c-addr 0    if not found ; flag Z=1       c-addr at transient RAM area (HERE)
 824 ;                  CFA -1      if found     ; flag Z=0
 825 ;                  CFA  1      if immediate ; flag Z=0
 826 ; compare WORD at c-addr (HERE)  with each of words in each of listed vocabularies in CONTEXT
 827 ; FIND to WORDLOOP  : 10/17 cycles,
 828 ; mismatch word loop: 14 cycles on len, 21 cycles on first char,
 829 ;                     +10 cycles char loop,
 830 ; WORDFOUND to end  : 16 cycles.
 831 ; note: with 16 threads vocabularies, FIND takes only! 75% of CORETEST.4th processing time
 832 FIND        SUB #2,PSP          ;1 -- ???? c-addr       reserve one cell, not at FINDEND which would kill the Z flag
 833             MOV TOS,S           ;1                      S=c-addr
 834             MOV #CONTEXT,T      ;2                      T = first cell addr of CONTEXT stack
 835 VOCLOOP     MOV @T+,TOS         ;2 -- ???? VOC_PFA      T=CTXT+2
 836             CMP #0,TOS          ;1                      no more vocabulary in CONTEXT ?
 837             JZ FINDEND          ;2 -- ???? 0            yes ==> exit; Z=1
 838     .SWITCH THREADS
 839     .CASE   1                   ;                       nothing to do
 840     .ELSECASE                   ;                       searching thread adds 7 cycles & 6 words
 841             MOV.B 1(S),Y        ;3 -- ???? VOC_PFA0     S=c-addr Y=first char of c-addr string
 842             AND.B #(THREADS-1),Y;2 -- ???? VOC_PFA0     Y=thread_x
 843             ADD Y,Y             ;1 -- ???? VOC_PFA0     Y=thread_offset_x
 844             ADD Y,TOS           ;1 -- ???? VOC_PFAx     TOS = words set entry
 845     .ENDCASE
 846             ADD #2,TOS          ;1 -- ???? VOC_PFAx+2
 847 WORDLOOP    MOV -2(TOS),TOS     ;3 -- ???? NFA          -2(TOS) = [VOC_PFAx] first, then [LFA]
 848             CMP #0,TOS          ;1 -- ???? NFA          no more word in the thread ?
 849             JZ VOCLOOP          ;2 -- ???? NFA          yes ==> search next voc in context
 850             MOV TOS,X           ;1
 851             MOV.B @X+,Y         ;2                      TOS = NFA,  X= NFA+1, Y = NFA_first_byte = cnt<<2+i (i= immediate flag)
 852             RRA.B Y             ;1                      remove immediate flag, the remainder is the count of the definition name.
 853 LENCOMP     CMP.B @S,Y          ;2                      compare lenght
 854             JNZ WORDLOOP        ;2 -- ???? NFA          14~ word loop on lenght mismatch
 855             MOV S,W             ;1                      S=W=c-addr
 856 CHARCOMP    CMP.B @X+,1(W)      ;4                      compare chars
 857             JNZ WORDLOOP        ;2 -- ???? NFA          21~ word loop on first char mismatch
 858             ADD #1,W            ;1
 859             SUB.B #1,Y          ;1                      decr count
 860             JNZ CHARCOMP        ;2 -- ???? NFA          10~ char loop
 861 WORDFOUND   BIT #1,X            ;1
 862             ADDC #0,X           ;1
 863             MOV X,S             ;1                      S=aligned CFA
 864             MOV.B @TOS,TOS      ;2 -- ???? NFA_1st_byte
 865             AND #1,TOS          ;1 -- ???? 0|1          test immediate flag
 866             JNZ FINDEND         ;2 -- ???? 1            jump if bit 1 is set, as immediate bit
 867             SUB #1,TOS          ;1 -- ???? -1
 868 FINDEND     MOV S,0(PSP)        ;3 not found: -- c-addr 0                           flag Z=1
 869             MOV @IP+,PC         ;4 34/40 words
 870
 871     .IFDEF MPY_32 ; if 32 bits hardware multiplier
 872
 873             FORTHWORD ">NUMBER"
 874 ; >NUMBER  ud1lo ud1hi addr1 cnt1 -- ud2lo ud2hi addr2 cnt2
 875 ; https://forth-standard.org/standard/core/toNUMBER
 876 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
 877 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
 878 ; Conversion continues left-to-right until a character that is not convertible (including '.'  ','  '_')
 879 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
 880 ; or the first character past the end of the string if the string was entirely converted.
 881 ; cnt2 is the number of unconverted characters in the string.
 882 ; An ambiguous condition exists if ud2 overflows during the conversion.
 883 TONUMBER    MOV &BASEADR,T      ;3                      T = base
 884             MOV @PSP+,S         ;2 -- ud1lo ud1hi cnt1  S = addr1
 885             MOV @PSP+,Y         ;2 -- ud1lo cnt1        Y = ud1hi
 886             MOV @PSP,X          ;2 -- x cnt1            X = ud1lo
 887             SUB #4,PSP          ;1 -- x x x cnt1
 888 TONUMLD_OP1 MOV T,&MPY          ;3                      base = MPY OP1 loaded out of TONUMLOOP
 889 TONUMLOOP   MOV.B @S,W          ;2 -- x x x cnt         S=adr, T=base, W=char, X=udlo, Y=udhi
 890 DDIGITQ     SUB.B #3Ah,W        ;2                      all Ctrl_Chars < '0'  and all chars '0' to '9' become negative
 891             JNC DDIGITQNEXT     ;2                      accept all chars U< ':'  (accept $0 up to $39)
 892             SUB.B #7,W          ;2                      W = char - ($3A + $07 = 'A')
 893             JNC TONUMEND        ;2 -- x x x cnt         reject all Ctrl_Chars U< 'A', (with Z flag = 0)
 894 DDIGITQNEXT ADD.B #0Ah,W        ;2                      restore digit value: 0 to 15 (and beyond)
 895             CMP T,W             ;1                      digit-base (U>= comparaison rejects all Ctrl_Chars)
 896             BIC #Z,SR           ;1                      reset Z before return to QNUMBER because else
 897             JC TONUMEND         ;2                      to avoid QNUMBER conversion true with digit=base :-(
 898 UDSTAR      MOV X,&OP2L         ;3                      Load 2nd operand (ud1lo)
 899             MOV Y,&OP2H         ;3                      Load 2nd operand (ud1hi)
 900             MOV &RES0,X         ;3                      lo result in X (ud2lo)
 901             MOV &RES1,Y         ;3                      hi result in Y (ud2hi)
 902 MPLUS       ADD W,X             ;1                      ud2lo + digit
 903             ADDC #0,Y           ;1                      ud2hi + carry
 904 TONUMPLUS   ADD #1,S            ;1                      adr+1
 905             SUB #1,TOS          ;1 -- x x x cnt         cnt-1
 906             JNZ TONUMLOOP       ;2                      if count <>0 33~ loop
 907 TONUMEND    MOV S,0(PSP)        ;3 -- x x addr2 cnt2
 908             MOV Y,2(PSP)        ;3 -- x ud2hi addr2 cnt2
 909             MOV X,4(PSP)        ;3 -- ud2lo ud2hi addr2 cnt2
 910             MOV @IP+,PC         ;4 40 words
 911
 912 ; ?NUMBER makes the interface between INTERPRET and >NUMBER; it's a subset of INTERPRET.
 913 ; convert a string to a signed number; FORTH 2012 prefixes $  %  # are recognized,
 914 ; FORTH 2012 'char' numbers also, digits separator '_' also.
 915 ; with DOUBLE_INPUT option, 32 bits signed numbers (with decimal point) are recognized,
 916 ; with FIXPOINT_INPUT option, Q15.16 signed numbers (with comma) are recognized.
 917 ; prefixes ' # % $ - are processed before calling >NUMBER
 918 ; chars . , _  are processed as >NUMBER exits.
 919 ;Z ?NUMBER  addr -- n|d -1  if convert ok ; flag Z=0, UF9=1 if double
 920 ;Z          addr -- addr 0  if convert ko ; flag Z=1
 921 QNUMBER                         ;  -- addr
 922         .IFDEF DOUBLE_NUMBERS   ;                           DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
 923             BIC #UF9,SR         ;2                          reset UserFlag_9 used as double number flag
 924         .ENDIF                  ;
 925             SUB #8,PSP          ;1 -- x x x x addr          make room for >NUMBER
 926             MOV TOS,6(PSP)      ;3 -- addr x x x addr       save TOS
 927             MOV #0,Y            ;1                          Y=ud1hi=0
 928             MOV #0,X            ;1                          X=ud1lo=0
 929             MOV &BASEADR,T      ;3                          T=BASE
 930             MOV TOS,S           ;1                          S=addr
 931             MOV #0,TOS          ;1                          TOS=sign of result
 932             PUSHM #2,TOS        ;4 R-- sign IP              PUSH TOS,IP
 933             MOV #TONUMEXIT,IP   ;2                          set TONUMEXIT as return from >NUMBER
 934             MOV.B @S+,TOS       ;2 -- addr x x x cnt        TOS=count, S=addr+1
 935 QNUMLDCHAR  MOV.B @S,W          ;2                          W=char
 936             SUB.B #'-',W        ;2
 937             JZ QNUMMINUS        ;2
 938             JC TONUMLD_OP1      ;2 -- addr x x x cnt        jump if char U> '-', case of numeric chars
 939 QBINARY     MOV #2,T            ;1                          preset base 2
 940             ADD.B #8,W          ;1                          binary '%' prefix ?     '%' + 8 = '-'
 941             JZ PREFIXNEXT       ;2                          yes
 942 QDECIMAL    ADD #8,T            ;1                          preset base 10
 943             ADD.B #2,W          ;1                          decimal '#' prefix ?    '#' + 2 = '%'
 944             JZ PREFIXNEXT       ;2                          yes
 945 QHEXA       MOV #16,T           ;2                          preset base 16
 946             CMP.B #1,W          ;1                          hex '$' prefix ?        '#' + 1 = '$'
 947             JZ PREFIXNEXT       ;2                          yes
 948 QTICK       CMP.B #4,W          ;1                          prefix = ' ?            '#' + 4 = "'"
 949             JNZ QNUMNEXT        ;2 -- addr x x x cnt        no, abort because prefix not recognized
 950             CMP #3,TOS          ;2                          count = 3 ?
 951             JNZ QNUMNEXT        ;2                          no, abort
 952             CMP.B @S+,1(S)      ;4 -- addr x x x 3          3rd char = 1st char = "'"   ?
 953             MOV.B @S,S          ;2                          does byte to word conversion
 954             MOV S,4(PSP)        ;3 -- addr ud2lo x x x      ud2lo = ASCII code of 'char'
 955             JMP QNUMNEXT        ;2 -- addr ud2lo x x x      with happy end if 3rd char = 1st char
 956 QNUMMINUS   MOV #-1,2(RSP)      ;3 R-- sign IP              set sign flag
 957 PREFIXNEXT  SUB #1,TOS          ;1 -- addr x x x cnt-1      TOS=count-1
 958             CMP.B @S+,0(S)      ;4                          S=adr+1; same prefix ?
 959             JNZ QNUMLDCHAR      ;2                          loopback if no
 960             JZ TONUMLD_OP1      ;2                          if yes, this 2nd prefix will be rejected by >NUMBER
 961 ; ------------------------------;46
 962 TONUMEXIT   mNEXTADR            ;  -- addr ud2lo-hi addr2 cnt2      R-- IP sign BASE    S=addr2
 963             JZ QNUMNEXT         ;2                                  TOS=0 and Z=1 if conversion is ok
 964             SUB #2,IP           ;1                                  redefines TONUMEXIT as >NUMBER return, if loopback applicable
 965             MOV.B @S,W          ;2                                  reload rejected char
 966             CMP.B #'_',W        ;2                                  rejected char by >NUMBER is a underscore ?
 967             JZ TONUMPLUS        ;2                                  yes: return to >NUMBER to skip char then resume conversion, 30~ loopback
 968         .IFDEF DOUBLE_NUMBERS   ;                                   DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
 969             BIT #UF9,SR         ;2                                  UF9 already set ? ( if you have typed .. )
 970             JNZ QNUMNEXT        ;2                                  yes, goto QNUMKO
 971             BIS #UF9,SR         ;2                                  set double number flag
 972         .ENDIF
 973         .IFDEF DOUBLE_INPUT     ;
 974             SUB.B #'.',W        ;2                                  rejected char by >NUMBER is a decimal point ?
 975             JZ TONUMPLUS        ;2                                  yes, loopback to >NUMBER to skip char, 45~ loopback
 976         .ENDIF                  ;
 977         .IFDEF FIXPOINT_INPUT   ;
 978             .IFDEF DOUBLE_INPUT
 979             ADD.B #2,W          ;1                                  rejected char by >NUMBER is a comma ? (',' - '.' + 2 = 0)
 980             .ELSE               ;
 981             CMP.B #',',W        ;2                                  rejected char by >NUMBER is a comma ?
 982             .ENDIF              ;
 983             JNZ QNUMNEXT        ;2                                  no: with Z=0 ==> goto QNUMKO
 984 S15Q16      MOV TOS,W           ;1 -- addr ud2lo x x x              W=cnt2
 985             MOV #0,X            ;1 -- addr ud2lo x 0 x              init X = ud2lo' = 0
 986 S15Q16LOOP  MOV X,2(PSP)        ;3 -- addr ud2lo ud2lo' 0 x         2(PSP) = ud2lo'
 987             SUB.B #1,W          ;1                                  decrement cnt2
 988             MOV W,X             ;1                                  X = cnt2-1
 989             ADD S,X             ;1                                  X = end_of_string-1,-2,-3...
 990             MOV.B @X,X          ;2                                  X = last char of string first (reverse conversion)
 991             SUB.B #':',X        ;2
 992             JNC QS15Q16DIGI     ;2                                  accept all chars U< ':'
 993             SUB.B #7,X          ;2
 994             JNC S15Q16EOC       ;2                                  reject all chars U< 'A'
 995 QS15Q16DIGI ADD.B #10,X         ;2                                  restore digit value
 996             CMP T,X             ;1                                  T=Base, is X a digit ?
 997             JC S15Q16EOC        ;2 -- addr ud2lo ud2lo' ud2lo' x    if not a digit
 998             MOV X,0(PSP)        ;3 -- addr ud2lo ud2lo' digit x
 999             MOV T,TOS           ;1 -- addr ud2lo ud2lo' digit base  R-- IP sign
1000             PUSHM #3,S          ;5                                  PUSH S,T,W: R-- IP sign addr2 base cnt2
1001             CALL #MUSMOD        ;4 -- addr ud2lo ur uqlo uqhi       CALL MU/MOD
1002             POPM #3,S           ;5                                  restore W,T,S: R-- IP sign
1003             JMP S15Q16LOOP      ;2                                  W=cnt
1004 S15Q16EOC   MOV 4(PSP),2(PSP)   ;5 -- addr ud2lo ud2hi uqlo x       ud2lo from >NUMBER becomes here ud2hi part of Q15.16
1005             MOV @PSP,4(PSP)     ;4 -- addr ud2lo ud2hi x x          uqlo becomes ud2lo part of Q15.16
1006             CMP.B #0,W          ;1                                  count = 0 if end of conversion ok
1007         .ENDIF ; FIXPOINT_INPUT
1008 ; ------------------------------;
1009 QNUMNEXT    POPM #2,TOS         ;4 -- addr ud2lo-hi x sign  R: --   POPM IP,TOS  TOS = sign flag = {-1;0}
1010             JZ QNUMOK           ;2 -- addr ud2lo-hi x sign          conversion OK if Z=1
1011 QNUMKO
1012         .IFDEF DOUBLE_NUMBERS   ;
1013             BIC #UF9,SR         ;2                                  reset flag UF9, before next use as double number flag
1014         .ENDIF
1015             ADD #6,PSP          ;2 -- addr sign
1016             AND #0,TOS          ;1 -- addr ff                       TOS=0 and Z=1 ==> conversion ko
1017             MOV @IP+,PC         ;4
1018 ; ------------------------------;
1019         .IFDEF DOUBLE_NUMBERS   ;  -- addr ud2lo-hi x sign
1020 QNUMOK      ADD #2,PSP          ;1 -- addr ud2lo-hi sign
1021             MOV 2(PSP),4(PSP)   ;5 -- udlo udlo udhi sign
1022             MOV @PSP+,0(PSP)    ;4 -- udlo udhi sign                note : PSP is incremented before write back.
1023             XOR #-1,TOS         ;1 -- udlo udhi inv(sign)
1024             JNZ QDOUBLE         ;2 -- udlo udhi tf                  if jump : TOS=-1 and Z=0 ==> conversion ok
1025             XOR #-1,TOS         ;1 -- udlo udhi tf
1026 QDNEGATE    XOR #-1,2(PSP)      ;3 -- udlo udhi -1
1027             XOR #-1,0(PSP)      ;3 -- (dlo dhi)-1 tf
1028             ADD #1,2(PSP)       ;3
1029             ADDC #0,0(PSP)      ;3
1030 QDOUBLE     BIT #UF9,SR         ;2 -- dlo dhi tf                    decimal point or comma fixpoint ?
1031             JNZ QNUMEND         ;2                                  leave double
1032 NIP         ADD #2,PSP          ;1 -- n tf                          leave number
1033 QNUMEND     MOV @IP+,PC         ;4                                  TOS<>0 and Z=0 ==> conversion ok
1034         .ELSE
1035 QNUMOK      ADD #4,PSP          ;1 -- addr ud2lo sign
1036             MOV @PSP,2(PSP)     ;4 -- u u sign                      note : PSP is incremented before write back !!!
1037             XOR #-1,TOS         ;1 -- udlo udhi inv(sign)
1038             JNZ QNUMEND         ;2 -- udlo udhi tf                  if jump : TOS=-1 and Z=0 ==> conversion ok
1039             XOR #-1,TOS         ;1 -- udlo udhi sign
1040 QNEGATE     XOR #-1,2(PSP)      ;3
1041             ADD #1,2(PSP)       ;3 -- n u tf
1042 QNUMEND
1043 NIP         ADD #2,PSP          ;1 -- n tf
1044             MOV @IP+,PC         ;4                                  TOS=-1 and Z=0 ==> conversion ok
1045         .ENDIF ; DOUBLE_NUMBERS ;
1046
1047     .ELSE ; if no hardware MPY
1048             FORTHWORD "UM*"
1049 ; T.I. UNSIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud
1050 ; https://forth-standard.org/standard/core/UMTimes
1051 ; UM*     u1 u2 -- ud   unsigned 16x16->32 mult.
1052 UMSTAR      MOV @PSP,S          ;2 MDlo
1053 UMSTAR1     MOV #0,T            ;1 MDhi=0
1054             MOV #0,X            ;1 RES0=0
1055             MOV #0,Y            ;1 RES1=0
1056             MOV #1,W            ;1 BIT TEST REGISTER
1057 UMSTARLOOP  BIT W,TOS           ;1 TEST ACTUAL BIT MRlo
1058             JZ UMSTARNEXT       ;2 IF 0: DO NOTHING
1059             ADD S,X             ;1 IF 1: ADD MDlo TO RES0
1060             ADDC T,Y            ;1      ADDC MDhi TO RES1
1061 UMSTARNEXT  ADD S,S             ;1 (RLA LSBs) MDlo x 2
1062             ADDC T,T            ;1 (RLC MSBs) MDhi x 2
1063             ADD W,W             ;1 (RLA) NEXT BIT TO TEST
1064             JNC UMSTARLOOP      ;2 IF BIT IN CARRY: FINISHED    10~ loop
1065             MOV X,0(PSP)        ;3 low result on stack
1066             MOV Y,TOS           ;1 high result in TOS
1067             MOV @IP+,PC         ;4 17 words
1068
1069             FORTHWORD ">NUMBER"
1070 ; https://forth-standard.org/standard/core/toNUMBER
1071 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
1072 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
1073 ; Conversion continues left-to-right until a character that is not convertible, including '.', ',' or '_',
1074 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
1075 ; or the first character past the end of the string if the string was entirely converted.
1076 ; u2 is the number of unconverted characters in the string.
1077 ; An ambiguous condition exists if ud2 overflows during the conversion.
1078 ; >NUMBER  ud1lo|ud1hi addr1 count1 -- ud2lo|ud2hi addr2 count2
1079 TONUMBER    MOV &BASEADR,W         ;3                          W = base
1080             MOV @PSP,S          ;2                          S=adr
1081             MOV TOS,T           ;1                          T=count
1082 TONUMLOOP   MOV.B @S,Y          ;2 -- ud1lo ud1hi x x       S=adr, T=count, W=BASE, Y=char
1083 DDIGITQ     SUB.B #':',Y        ;2
1084             JNC DDIGITQNEXT     ;2                          accept all chars <= 9
1085             SUB.B #07,Y         ;2                          reject all chars between "9" and "A"
1086             JNC TONUMEND        ;2                          yes: for bad end
1087 DDIGITQNEXT ADD.B #10,Y         ;2                          restore number
1088             CMP W,Y             ;1 -- ud1lo ud1hi x x       digit-base
1089             BIC #Z,SR           ;1                          reset Z before jmp TONUMEND because...
1090             JC TONUMEND         ;2                          ...QNUMBER conversion will be true if Z = 1  :-(
1091 UDSTAR      PUSHM #6,IP         ;8 -- ud1lo ud1hi x x       save IP S T W X Y used by UM*   r-- IP adr count base x digit
1092             MOV 2(PSP),S        ;3 -- ud1lo ud1hi x x       S=ud1hi
1093             MOV W,TOS           ;1 -- ud1lo ud1hi x base
1094             MOV #UMSTARNEXT1,IP ;2
1095 UMSTARONE   JMP UMSTAR1         ;2                          ud1hi * base -- x ud3hi             X=ud3lo
1096 UMSTARNEXT1 mNEXTADR            ;  -- ud1lo ud1hi x ud3hi
1097             MOV X,2(RSP)        ;3                                                          r-- IP adr count base ud3lo digit
1098             MOV 4(PSP),S        ;3 -- ud1lo ud1hi x ud3hi   S=ud1lo
1099             MOV 4(RSP),TOS      ;3 -- ud1lo ud1hi x base
1100             MOV #UMSTARNEXT2,IP ;2
1101 UMSTARTWO   JMP UMSTAR1         ;2 -- ud1lo ud1hi x ud4hi   X=ud4lo
1102 UMSTARNEXT2 mNEXTADR            ;  -- ud1lo ud1hi x ud4hi
1103 MPLUS       ADD @RSP+,X         ;2 -- ud1lo ud1hi x ud4hi   X=ud4lo+digit=ud2lo             r-- IP adr count base ud3lo
1104             ADDC @RSP+,TOS      ;2 -- ud1lo ud1hi x ud2hi   TOS=ud4hi+ud3lo+carry=ud2hi     r-- IP adr count base
1105             MOV X,4(PSP)        ;3 -- ud2lo ud1hi x ud2hi
1106             MOV TOS,2(PSP)      ;3 -- ud2lo ud2hi x x                                       r-- IP adr count base
1107             POPM #4,IP          ;6 -- ud2lo ud2hi x x       W=base, T=count, S=adr, IP=prevIP   r--
1108 TONUMPLUS   ADD #1,S            ;1
1109             SUB #1,T            ;1
1110             JNZ TONUMLOOP       ;2 -- ud2lo ud2hi x x       S=adr+1, T=count-1, W=base     68 cycles char loop
1111 TONUMEND    MOV S,0(PSP)        ;3 -- ud2lo ud2hi adr2 count2
1112             MOV T,TOS           ;1 -- ud2lo ud2hi adr2 count2
1113             MOV @IP+,PC         ;4 48/82 words/cycles, W = BASE
1114
1115 ; ?NUMBER makes the interface between >NUMBER and INTERPRET; it's a subset of INTERPRET.
1116 ; convert a string to a signed number; FORTH 2012 prefixes ' $, %, # are recognized
1117 ; digits separator '_' also.
1118 ; with DOUBLE_INPUT switched ON, 32 bits signed numbers (with decimal point) are recognized
1119 ; with FIXPOINT_INPUT switched ON, Q15.16 signed numbers (with comma) are recognized.
1120 ; prefixes ' # % $ - are processed before calling >NUMBER
1121 ; chars . , _ are processed as >NUMBER exits
1122 ;Z ?NUMBER  addr -- n|d -1  if convert ok ; flag Z=0, UF9=1 if double
1123 ;Z          addr -- addr 0  if convert ko ; flag Z=1
1124 QNUMBER
1125         .IFDEF DOUBLE_NUMBERS   ;           DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1126             BIC #UF9,SR         ;2          reset flag UF9, before use as double number flag
1127         .ENDIF                  ;
1128             SUB #8,PSP          ;1 -- x x x x addr
1129             MOV TOS,6(PSP)      ;3 -- addr x x x addr   save TOS
1130             MOV #0,4(PSP)       ;3                      ud1hi=0
1131             MOV #0,2(PSP)       ;3 -- addr 0 0 x addr   ud1lo=0
1132             MOV &BASEADR,W      ;3                      W=BASE
1133             MOV TOS,S           ;1 -- addr ud=0 x x     S=addr
1134             MOV #0,TOS          ;1
1135             PUSHM #2,TOS        ;4          R-- sign IP (push TOS,IP)
1136             MOV #TONUMEXIT,IP   ;2                      define >NUMBER return
1137             MOV.B @S+,T         ;2                      S=addr+1, T=count
1138 QNUMLDCHAR  MOV.B @S,Y          ;2                      Y=char
1139             SUB.B #'-',Y        ;2 -- addr ud=0 x x     sign minus ?
1140             JZ QNUMMINUS        ;2                      yes
1141             JC TONUMLOOP        ;2                      if char U> '-'
1142 QBINARY     MOV #2,W            ;1                      preset base 2
1143             ADD.B #8,Y          ;1                      binary prefix ?     '%' = '-' + 8
1144             JZ PREFIXNEXT       ;2                      yes
1145 QDECIMAL    ADD #8,W            ;1                      preset base 10
1146             ADD.B #2,Y          ;1                      decimal prefix ?    '#' = '%' + 2
1147             JZ PREFIXNEXT       ;2                      yes
1148 QHEXA       MOV #16,W           ;2                      preset base 16
1149             CMP.B #1,Y          ;1                      hex prefix ?        '$' = '#' + 1
1150             JZ PREFIXNEXT       ;2                      yes
1151 QTICK       CMP.B #4,Y          ;1                      prefix = ' ?        "'" = '#' + 4
1152             JNZ QNUMNEXT        ;2 -- addr x x x cnt    abort if not recognized prefix
1153             CMP #3,TOS          ;
1154             JNZ QNUMNEXT        ;
1155             CMP.B @S+,1(S)      ;4                      compare 3rd with first char '
1156             MOV.B @S,S          ;2                      does char to word conversion
1157             MOV S,4(PSP)        ;5 -- addr ud2lo 0 x x  ud2lo = ASCII code of 'char'
1158             JMP QNUMNEXT        ;2                      with happy end if flag Z = 1
1159 QNUMMINUS   MOV #-1,2(RSP)      ;3 R-- sign IP          set sign flag
1160 PREFIXNEXT  SUB #1,T            ;1                      T=count-1
1161             CMP.B @S+,0(S)      ;4                      S=adr+1; same prefix ?
1162             JNZ QNUMLDCHAR      ;2                      no
1163             JZ TONUMLOOP        ;2                      yes, that will abort conversion
1164 ; ------------------------------;43
1165 TONUMEXIT   mNEXTADR            ;  -- addr ud2lo-hi addr2 cnt2      R-- IP sign BASE    S=addr2,T=cnt2
1166             JZ QNUMNEXT         ;2                                  if conversion is ok
1167             SUB #2,IP
1168             MOV.B @S,Y          ;                                   regenerate rejected char
1169             CMP.B #'_',Y        ;2                                  rejected char by >NUMBER is a underscore ?
1170             JZ TONUMPLUS        ;                                   yes: loopback to >NUMBER to skip char
1171         .IFDEF DOUBLE_NUMBERS   ;                                   DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1172             BIT #UF9,SR         ;                                   UF9 already set ? (you have wrongly typed two points)
1173             JNZ QNUMNEXT        ;                                   yes, goto QNUMKO
1174             BIS #UF9,SR         ;2                                  set double number flag
1175         .ENDIF
1176         .IFDEF DOUBLE_INPUT
1177             SUB.B #'.',Y        ;1                                  rejected char by >NUMBER is a decimal point ?
1178             JZ TONUMPLUS        ;2                                  to terminate conversion
1179         .ENDIF
1180         .IFDEF FIXPOINT_INPUT   ;
1181             .IFDEF DOUBLE_INPUT
1182             ADD.B #2,Y          ;1                                  rejected char by >NUMBER is a comma ?
1183             .ELSE
1184             SUB.B #',',Y        ;1                                  rejected char by >NUMBER is a comma ?
1185             .ENDIF
1186             JNZ QNUMNEXT        ;2                                  no, goto QNUMKO
1187 S15Q16      MOV #0,X            ;1 -- addr ud2lo x 0 x              init ud2lo' = 0
1188 S15Q16LOOP  MOV X,2(PSP)        ;3 -- addr ud2lo ud2lo' ud2lo' x    X = 0(PSP) = ud2lo'
1189             SUB.B #1,T          ;1                                  decrement cnt2
1190             MOV T,X             ;1                                  X = cnt2-1
1191             ADD S,X             ;1                                  X = end_of_string-1, first...
1192             MOV.B @X,X          ;2                                  X = last char of string, first...
1193             SUB.B #':',X        ;2
1194             JNC QS15Q16DIGI     ;2                                  accept all chars U< ':'
1195             SUB.B #7,X          ;2
1196             JNC S15Q16EOC       ;2                                  reject all chars U< 'A'
1197 QS15Q16DIGI ADD.B #10,X         ;2                                  restore number
1198             CMP W,X             ;1                                  W=BASE, is X a digit ?
1199             JC  S15Q16EOC       ;2 -- addr ud2lo ud2lo' x ud2lo'    if not a digit
1200             MOV X,0(PSP)        ;3 -- addr ud2lo ud2lo' digit x
1201             MOV W,TOS           ;1 -- addr ud2lo ud2lo' digit base  R-- IP sign
1202             PUSHM #3,S          ;5                                  PUSH S,T,W: R-- IP sign addr2 cnt2 base
1203             CALL #MUSMOD        ;4 -- addr ud2lo ur uqlo uqhi
1204             POPM #3,S           ;5                                  restore W,T,S: R-- IP sign
1205             JMP S15Q16LOOP      ;2                                  W=cnt
1206 S15Q16EOC   MOV 4(PSP),2(PSP)   ;5 -- addr ud2lo ud2lo uqlo x       ud2lo from >NUMBER part1 becomes here ud2hi=S15 part2
1207             MOV @PSP,4(PSP)     ;4 -- addr ud2lo ud2hi x x          uqlo becomes ud2lo
1208             CMP.B #0,T          ;1                                  cnt2 = 0 if end of conversion ok
1209         .ENDIF ; FIXPOINT_INPUT ;
1210 ; ------------------------------;97
1211 QNUMNEXT    POPM #2,TOS         ;4 -- addr ud2lo-hi x sign  R: --   POPM IP,TOS  TOS = sign flag = {-1;0}
1212             JZ QNUMOK           ;2 -- addr ud2lo-hi x sign          conversion OK if Z=1
1213 QNUMKO                          ;                                   flag Z=0
1214         .IFDEF DOUBLE_NUMBERS
1215             BIC #UF9,SR
1216         .ENDIF
1217             ADD #6,PSP          ;1 -- addr sign
1218             AND #0,TOS          ;1 -- addr ff                       TOS=0 and Z=1 ==> conversion ko
1219             MOV @IP+,PC         ;4
1220 ; ------------------------------;
1221         .IFDEF DOUBLE_NUMBERS
1222 QNUMOK      ADD #2,PSP          ;1 -- addr ud2lo ud2hi sign
1223             MOV 2(PSP),4(PSP)   ;  -- udlo udlo udhi sign
1224             MOV @PSP+,0(PSP)    ;4 -- udlo udhi sign                note : PSP is incremented before write back !!!
1225             XOR #-1,TOS         ;1 -- udlo udhi inv(sign)
1226             JNZ QDOUBLE         ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
1227             XOR #-1,TOS         ;1 -- udlo udhi tf
1228 Q2NEGATE    XOR #-1,2(PSP)      ;3
1229             XOR #-1,0(PSP)      ;3
1230             ADD #1,2(PSP)       ;3
1231             ADDC #0,0(PSP)      ;3 -- dlo dhi tf
1232 QDOUBLE     BIT #UF9,SR         ;2 -- dlo dhi tf                decimal point added ?
1233             JNZ QNUMEND         ;2 -- dlo dhi tf                leave double
1234 NIP         ADD #2,PSP          ;1 -- dlo tf                    leave number, Z=0
1235 QNUMEND     MOV @IP+,PC         ;4                              TOS=-1 and Z=0 ==> conversion ok
1236         .ELSE
1237 QNUMOK      ADD #4,PSP          ;1 -- addr ud2lo sign
1238             MOV @PSP,2(PSP)     ;4 -- udlo udlo sign            note : PSP is incremented before write back !!!
1239             XOR #-1,TOS         ;1 -- udlo udlo inv(sign)
1240             JNZ QNUMEND         ;2                              if jump : TOS=-1 and Z=0 ==> conversion ok
1241             XOR #-1,TOS         ;1 -- udlo udlo tf                   TOS=-1 and Z=0
1242 QNEGATE     XOR #-1,2(PSP)      ;3
1243             ADD #1,2(PSP)       ;3 -- n udlo tf
1244 QNUMEND
1245 NIP         ADD #2,PSP          ;1
1246             MOV @IP+,PC         ;4                              TOS=-1 and Z=0 ==> conversion ok
1247         .ENDIF ; DOUBLE_NUMBERS
1248     .ENDIF ; of Hardware/Software MPY
1249
1250             FORTHWORDIMM "\\"       ; immediate
1251 ; https://forth-standard.org/standard/block/bs
1252 ; \         --      backslash
1253 ; everything up to the end of the current line is a comment.
1254 BACKSLASH   MOV &SOURCE_LEN,&TOIN   ;
1255             MOV @IP+,PC
1256
1257 ; INTERPRET    i*x addr u -- j*x      interpret given buffer
1258 ; This is the common factor of EVALUATE and QUIT.
1259 ; set addr u as input buffer then parse it word by word
1260 INTERPRET   mDOCOL              ;               INTERPRET = BACKSLASH + 8
1261             .word SETIB         ; --            set input buffer pointers
1262 INTLOOP     .word BL,WORDD      ; -- c-addr fl  flag Z = 1 <=> End Of Line
1263             .word ZBRAN,FDROPEXIT;              BRANch to DROPEXIT if Z = 1
1264             .word FIND
1265             mNEXTADR            ; -- xt|c-addr|xt -1|0|+1   Z=1 --> not found
1266             MOV TOS,W           ;                           W = flag = (-1|0|+1) as (not_immediate|not_found|immediate)
1267             MOV @PSP+,TOS       ; -- xt|c-addr|xt
1268             MOV #INTQNUMNEXT,IP ;2              INTQNUMNEXT is the continuation of QNUMBER
1269             JZ QNUMBER          ;2              if Z=1 --> not found, search a number
1270             MOV #INTLOOP,IP     ;2              INTLOOP is the continuation of EXECUTE|COMMA
1271             XOR &STATE,W        ;3
1272             JZ COMMA            ;2 -- xt        if W xor STATE = 0 compile xt, then loop back to INTLOOP
1273 EXECUTE     PUSH TOS            ;3 -- xt
1274             MOV @PSP+,TOS       ;2 --
1275             MOV @RSP+,PC        ;4              xt --> PC, then loop back to INTLOOP
1276 ; ------------------------------;
1277 INTQNUMNEXT mNEXTADR            ;  -- n|c-addr fl   Z = 1 --> not a number, SR(UF9) double number request
1278             MOV @PSP+,TOS       ;2 -- n|c-addr
1279             MOV #INTLOOP,IP     ;2              INTLOOP is the continuation of LITERAL.
1280             JNZ LITERAL         ;2 n --         Z = 0 --> is a number, execute LITERAL then loop back to INTLOOP
1281 NotFoundexe ADD.B #1,0(TOS)     ;3 c-addr --    Z = 1 --> Not a Number : incr string count to add '?'
1282             MOV.B @TOS,Y        ;2              Y=count+1
1283             ADD TOS,Y           ;1              Y=end of string addr
1284             MOV.B #'?',0(Y)     ;5              add '?' to end of string
1285             MOV #FABORT_TERM,IP ;2              ABORT_TERM is the continuation of COUNT
1286             JMP COUNT           ;2 -- addr len  37 words
1287
1288 ;-------------------------------------------------------------------------------
1289 ; DICTIONARY MANAGEMENT
1290 ;-------------------------------------------------------------------------------
1291             FORTHWORD ","
1292 ; https://forth-standard.org/standard/core/Comma
1293 ; ,    x --           append cell to dict
1294 COMMA       ADD #2,&DP          ;3
1295             MOV &DP,W           ;3
1296             MOV TOS,-2(W)       ;3
1297             MOV @PSP+,TOS       ;2
1298             MOV @IP+,PC         ;4 15~      W = DP
1299
1300             FORTHWORDIMM "LITERAL"  ; immediate
1301 ; https://forth-standard.org/standard/core/LITERAL
1302 ; LITERAL  n --        append single numeric literal if compiling state
1303 ;          d --        append two numeric literals if compiling state and UF9<>0 (not ANS)
1304     .IFDEF DOUBLE_NUMBERS       ; are recognized
1305 LITERAL     CMP #0,&STATE       ;3
1306             JZ LITERALNEXT      ;2 if interpreting state, does nothing else clear UF9 flag
1307             MOV TOS,X           ;1          X = n|dhi
1308 LITERALLOOP MOV &DP,W           ;3
1309             ADD #4,&DP          ;3
1310             MOV #lit,0(W)       ;4
1311             MOV X,2(W)          ;3 pass 1: compile n|dhi, if pass 2: compile dhi
1312             MOV @PSP+,TOS       ;2
1313             BIT #UF9,SR         ;2 double number ?
1314 LITERALNEXT BIC #UF9,SR         ;2    in all case, clear UF9
1315             JZ LITERALEND       ;2 goto end if n|interpret_state
1316             MOV TOS,2(W)        ;3 compile dlo over dhi
1317             JMP LITERALLOOP     ;2
1318 LITERALEND  MOV @IP+,PC         ;4
1319     .ELSE
1320 LITERAL     CMP #0,&STATE       ;3
1321             JZ LITERALEND       ;2 if interpreting state, does nothing
1322             MOV &DP,W           ;3
1323             ADD #4,&DP          ;3
1324             MOV #lit,0(W)       ;4
1325             MOV TOS,2(W)        ;3
1326             MOV @PSP+,TOS       ;2
1327 LITERALEND  MOV @IP+,PC         ;4
1328     .ENDIF
1329
1330             FORTHWORD "COUNT"
1331 ; https://forth-standard.org/standard/core/COUNT
1332 ; COUNT   c-addr1 -- adr len   counted->adr/len
1333 COUNT       SUB #2,PSP          ;1
1334             MOV.B @TOS+,W       ;2
1335             MOV TOS,0(PSP)      ;3
1336             MOV W,TOS           ;1
1337             AND #-1,TOS         ;       Z is set if u=0
1338             MOV @IP+,PC         ;4 14~
1339
1340             FORTHWORD "ALLOT"
1341 ; https://forth-standard.org/standard/core/ALLOT
1342 ; ALLOT   n --         allocate n bytes
1343 ALLOT       ADD TOS,&DP
1344             MOV @PSP+,TOS
1345             MOV @IP+,PC
1346
1347 ;            FORTHWORD "ABORT"
1348 ; https://forth-standard.org/standard/core/ABORT
1349 ; Empty the data stack and perform the function of QUIT,
1350 ; which includes emptying the return stack, without displaying a message.
1351 ; ABORT is the common next of WARM and ABORT"
1352 ABORT       MOV #PSTACK,PSP         ; ABORT = ALLOT + 8
1353             MOV #0,TOS              ; and set TOS for SYS use.
1354 ; https://forth-standard.org/standard/core/QUIT
1355 ; QUIT  --     interpret line by line the input stream
1356 QUIT        mASM2FORTH              ; QUIT = ALLOT + 14
1357     .IFDEF PROMPT
1358 QUIT1       .word   XSQUOTE         ; lower interpret loop
1359             .byte   5,13,10,"ok "   ; CR + LF + Forth prompt
1360 QUIT2
1361     .ELSE
1362 QUIT2       .word   XSQUOTE
1363             .byte   2,13,10         ; CR+LF
1364     .ENDIF
1365             .word   TYPE            ;
1366             .word   REFILL          ; -- org len      refill input buffer from ACCEPT (one line)
1367 QUIT4       .word   INTERPRET       ; interpret  input buffer|string
1368 QUIT5       .word   DEPTH,ZEROLESS  ; stack empty test
1369             .word   XSQUOTE         ; ABORT" stack empty! "
1370             .byte   11,"stack empty";
1371             .word   QABORT          ; see QABORT in forthMSP430FR_TERM_xxx.asm
1372             .word   HEREXEC         ; )
1373             .word   lit,FRAM_FULL   ; > FRAM full test
1374             .word   UMORE           ; )
1375             .word   XSQUOTE         ; ABORT" FRAM full! "
1376             .byte   9,"FRAM full"   ;
1377             .word   QABORT          ; see QABORT in forthMSP430FR_TERM_xxx.asm
1378     .IFDEF PROMPT
1379             .word   lit,STATE,FETCH ; STATE @
1380             .word   QFBRAN,QUIT1    ; 0= case of interpretion state
1381             .word   XSQUOTE         ; 0<> case of compilation state
1382             .byte   5,13,10,"   "   ; CR+LF + 3 spaces
1383     .ENDIF
1384             .word   BRAN,QUIT2
1385
1386             FORTHWORDIMM "ABORT\34"
1387 ; ; ABORT" is enabled in interpretation mode (+ 17 words) :
1388 ;             CMP #0,&STATE
1389 ;             JNZ CMPL_QABORT
1390 ;             MOV #0,&CAPS            ; CAPS OFF
1391 ; EXEC_QABORT mDOCOL
1392 ;             .word   LIT,'"',WORDD,COUNT,QABORT
1393 ;             .word   BL,LIT,CAPS,STORE
1394 ;             .word   EXIT
1395
1396 ; https://forth-standard.org/standard/core/ABORTq
1397 ; ABORT" " (empty string) displays nothing
1398 ; ABORT"  i*x flag -- i*x   R: j*x -- j*x  flag=0
1399 ;         i*x flag --       R: j*x --      flag<>0
1400 CMPL_QABORT mDOCOL
1401             .word   SQUOTE
1402             .word   lit,QABORT,COMMA    ; see QABORT in forthMSP430FR_TERM_xxx.asm
1403             .word   EXIT
1404
1405 ;-------------------------------------------------------------------------------
1406 ; COMPILER
1407 ;-------------------------------------------------------------------------------
1408             FORTHWORD "'"
1409 ; https://forth-standard.org/standard/core/Tick
1410 ; '    -- xt           find word in dictionary and leave on stack its execution address
1411 TICK        mDOCOL
1412             .word   BL,WORDD,FIND
1413             .word   ZBRAN,NotFound  ; BRANch to NotFound if Z = 1
1414 FDROPEXIT   .word   DROPEXIT
1415 NotFound    .word   NotFoundExe     ; see INTERPRET
1416
1417
1418             FORTHWORDIMM "[']"      ; immediate word, i.e. word executed during compilation
1419 ; https://forth-standard.org/standard/core/BracketTick
1420 ; ['] <name>        --         find word & compile it as literal
1421 BRACTICK    mDOCOL
1422             .word   TICK            ; get xt of <name>
1423             .word   lit,lit,COMMA   ; append lit action
1424             .word   COMMA,EXIT      ; append xt literal
1425
1426             FORTHWORDIMM "["    ; immediate
1427 ; https://forth-standard.org/standard/core/Bracket
1428 ; [        --      enter interpretative state
1429 LEFTBRACKET
1430             MOV #0,&STATE
1431             MOV @IP+,PC
1432
1433             FORTHWORD "]"
1434 ; https://forth-standard.org/standard/core/right-bracket
1435 ; ]        --      enter compiling state
1436 RIGHTBRACKET
1437             MOV  #-1,&STATE
1438             MOV @IP+,PC
1439
1440             FORTHWORDIMM "POSTPONE"
1441 ; https://forth-standard.org/standard/core/POSTPONE
1442 POSTPONE    mDOCOL
1443             .word   BL,WORDD,FIND
1444             .word   ZBRAN,NotFound  ; BRANch to NotFound if Z = 1
1445             .word   ZEROLESS        ; immediate word ?
1446             .word   QFBRAN,POST1    ; if immediate
1447             .word   lit,lit,COMMA   ; else  compile lit
1448             .word   COMMA           ;       compile xt
1449             .word   lit,COMMA       ;       CFA of COMMA
1450 POST1       .word   COMMA,EXIT      ; then compile xt of word found if immediate else CFA of COMMA
1451
1452             FORTHWORD ":"
1453 ; https://forth-standard.org/standard/core/Colon
1454 ; : <name>     --      begin a colon definition
1455 COLON       PUSH #COLONNEXT         ;3              define COLONNEXT as HEADER return
1456 ;-----------------------------------;
1457 HEADER      BIT #1,&DP              ;3              carry set if odd
1458             ADDC #2,&DP             ;4              align and make room for LFA
1459             mDOCOL                  ;
1460             .word BL,WORDD          ;               W=Count_of_chars
1461             mNEXTADR                ; -- HERE       HERE is the NFA of this new word
1462             MOV @RSP+,IP            ;
1463             BIS.B #1,W              ;               W=count is always odd
1464             ADD.B #1,W              ;               W=add one byte for length
1465             ADD TOS,W               ;               W=Aligned_CFA
1466             MOV &CURRENT,X          ;               X=VOC_BODY of CURRENT
1467             MOV TOS,Y               ;               Y=NFA
1468     .SWITCH THREADS                 ;
1469     .CASE   1                       ;               nothing to do
1470     .ELSECASE                       ;               multithreading add 5~ 4words
1471             MOV.B 1(TOS),TOS        ; -- char       TOS=first CHAR of new word
1472             AND #(THREADS-1),TOS    ; -- offset     TOS= thread_offset
1473             ADD TOS,TOS             ;               TOS= thread_offset * 2
1474             ADD TOS,X               ;               X=VOC_PFAx = thread x of VOC_PFA of CURRENT
1475     .ENDCASE                        ;
1476             MOV @PSP+,TOS           ; --
1477             ADD.B @Y,0(Y)           ;               shift left once NFA_1st_byte (make room for immediate flag)
1478 HEADEREND   MOV Y,&LAST_NFA         ;               NFA --> LAST_NFA            used by QREVEAL, IMMEDIATE
1479             MOV X,&LAST_THREAD      ;               VOC_PFAx --> LAST_THREAD    used by QREVEAL
1480             MOV W,&LAST_CFA         ;               HERE=CFA --> LAST_CFA       used by DOES>, RECURSE
1481             MOV PSP,&LAST_PSP       ;               save PSP for check compiling, used by QREVEAL
1482             ADD #4,W                ;               by default make room for two words...
1483             MOV W,&DP               ;
1484             MOV @RSP+,PC            ; RET           W is the new DP value )
1485                                     ;               X is LAST_THREAD      > used by compiling words: CREATE, DEFER, :...
1486 COLONNEXT                           ;               Y is NFA              )
1487     .SWITCH DTC                     ; Direct Threaded Code select
1488     .CASE 1                         ;
1489             MOV #DOCOL,-4(W)        ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL)
1490             SUB #2,&DP              ;
1491     .CASE 2                         ;
1492             MOV #120Dh,-4(W)        ; compile PUSH IP       3~
1493             MOV #DOCOL,-2(W)        ; compile CALL R4 = rDOCOL ([rDOCOL] = EXIT)
1494     .CASE 3                         ;
1495             MOV #120Dh,-4(W)        ; compile PUSH IP       3~
1496             MOV #400Dh,-2(W)        ; compile MOV PC,IP     1~
1497             MOV #522Dh,0(W)         ; compile ADD #4,IP     1~
1498             MOV #4D30h,+2(W)        ; compile MOV @IP+,PC   4~
1499             ADD #4,&DP              ;
1500     .ENDCASE                        ;
1501             MOV #-1,&STATE          ; enter compiling state
1502             MOV @IP+,PC             ;
1503 ;-----------------------------------;
1504
1505 ;;Z ?REVEAL   --      if no stack mismatch, link this new word in the CURRENT vocabulary
1506 QREVEAL     CMP PSP,&LAST_PSP       ; Check SP with its saved value by :, :NONAME, CODE...
1507             JZ LINK_NFA             ; see MARKER
1508 BAD_CSP     mASM2FORTH              ; if stack mismatch.
1509             .word   XSQUOTE
1510             .byte   15,"stack mismatch!"
1511 FABORT_TERM .word   ABORT_TERM
1512
1513             FORTHWORDIMM ";"
1514 ; https://forth-standard.org/standard/core/Semi
1515 ; ;            --      end a colon definition
1516 SEMICOLON   CMP #0,&STATE           ; if interpret mode, semicolon becomes a comment identifier
1517             JZ BACKSLASH            ; tip: ";" is transparent to the preprocessor, so semicolon comments are kept in file.4th
1518             mDOCOL                  ; compile mode
1519             .word   lit,EXIT,COMMA
1520             .word   QREVEAL,LEFTBRACKET,EXIT
1521
1522             FORTHWORD "IMMEDIATE"
1523 ; https://forth-standard.org/standard/core/IMMEDIATE
1524 ; IMMEDIATE        --   make last definition immediate
1525 IMMEDIATE   MOV &LAST_NFA,Y         ; Y = NFA|unused_PA_reg (as lure for :NONAME)
1526             BIS.B #1,0(Y)           ;4 FIND process more easier with bit0 than bit7
1527 NEXTADR     MOV @IP+,PC
1528
1529             FORTHWORD "CREATE"
1530 ; https://forth-standard.org/standard/core/CREATE
1531 ; CREATE <name>        --          define a CONSTANT with its next address
1532 ; Execution: ( -- a-addr )          ; a-addr is the address of name's data field
1533 ;                                   ; the execution semantics of name may be extended by using DOES>
1534 CREATE      CALL #HEADER            ; --        W = DP
1535             MOV #DOCON,-4(W)        ;4          -4(W) = CFA = CALL rDOCON
1536             MOV W,-2(W)             ;3          -2(W) = PFA = W = next address
1537             JMP REVEAL              ;           to link the definition in vocabulary
1538
1539             FORTHWORD "DOES>"
1540 ; https://forth-standard.org/standard/core/DOES
1541 ; DOES>    --          set action for the latest CREATEd definition
1542 DOES        MOV &LAST_CFA,W         ;           W = CFA of CREATEd word
1543             MOV #DODOES,0(W)        ;           replace CALL rDOCON of CREATE by new CFA: CALL rDODOES
1544             MOV IP,2(W)             ;           replace PFA by the address after DOES> as execution address
1545             MOV @RSP+,IP            ;           which ends the..
1546             MOV @IP+,PC             ;           ..of a CREATE  definition.
1547
1548             FORTHWORD ":NONAME"
1549 ; https://forth-standard.org/standard/core/ColonNONAME
1550 ; :NONAME        -- xt
1551 ; W is DP
1552 ; X is the LAST_THREAD lure value for REVEAL
1553 ; Y is the LAST_NFA lure value for REVEAL and IMMEDIATE
1554 ; ...because we don't want to modify the word set !
1555             PUSH #COLONNEXT         ; define COLONNEXT as HEADEREND RET
1556 HEADERLESS  SUB #2,PSP              ; common part of :NONAME and CODENNM
1557             MOV TOS,0(PSP)          ;
1558             MOV &DP,W               ;
1559             BIT #1,W                ;
1560             ADDC #0,W               ;           W = aligned CFA
1561             MOV W,TOS               ; -- xt     aligned CFA of :NONAME | CODENNM
1562             MOV #212h,X             ;           MOV @X,-2(Y) writes to 210h = unused PA register address (lure for REVEAL and IMMEDIATE)
1563             MOV X,Y                 ;           MOV Y,0(X)   writes to 212h = unused PA register address (lure for REVEAL)
1564             JMP HEADEREND           ;
1565
1566 ;; https://forth-standard.org/standard/core/DEFER
1567 ;; Skip leading space delimiters. Parse name delimited by a space.
1568 ;; Create a definition for name with the execution semantics defined below.
1569 ;;
1570 ;; name Execution:   --
1571 ;; Execute the xt that name is set to execute, i.e. NEXT (nothing),
1572 ;; until the phrase ' word IS name is executed, causing a new value of xt to be assigned to name.
1573 ;            FORTHWORD "DEFER"
1574 ;            CALL #HEADER
1575 ;            MOV #4030h,-4(W)        ;4 first CELL = MOV @PC+,PC = BR #addr
1576 ;            MOV #NEXTADR,-2(W)      ;3 second CELL              =   ...mNEXT : do nothing by default
1577 ;            JMP REVEAL              ; to link created word in vocabulary
1578
1579 ; IS <name>        xt --
1580
1581 ; used like this (high level defn.):
1582 ;   DEFER DISPLAY                       create a "do nothing" definition (2 CELLS)
1583
1584 ; or (low level defn.):
1585 ;   CODE DISPLAY                        create a "do nothing" definition (2 CELLS)
1586 ;   MOV #NEXT_ADR,PC                    NEXT_ADR is the address of NEXT code: MOV @IP+,PC
1587 ;   ENDCODE
1588
1589 ; inline command : ' U. IS DISPLAY      U. becomes the runtime of the word DISPLAY
1590 ; or in a definition : ... ['] U. IS DISPLAY ... ;
1591 ; KEY, EMIT, ACCEPT are examples of DEFERred words
1592             FORTHWORDIMM "IS"       ; immediate
1593 IS          PUSH IP
1594             CMP #0,&STATE
1595             JNZ IS_COMPILE
1596 IS_EXEC     mASM2FORTH
1597             .word   TICK
1598             mNEXTADR
1599             MOV @RSP+,IP
1600 DEFERSTORE  MOV @PSP+,2(TOS)        ; -- CFA_DEFERed_WORD          xt --> [PFA_DEFERed_WORD]
1601             MOV @PSP+,TOS           ; --
1602             MOV @IP+,PC             ;
1603
1604 IS_COMPILE  mASM2FORTH
1605             .word   BRACTICK             ; find the word, compile its CFA as literal
1606             .word   lit,DEFERSTORE,COMMA ; compile DEFERSTORE
1607             .word   EXIT
1608
1609            FORTHWORD "CODE"         ; a CODE word must be finished with ENDCODE
1610 ASMCODE     CALL #HEADER            ; (that sets CFA and PFA)
1611 ASMCODE1    SUB #4,&DP              ; remove default CFA and PFA
1612 ASMCODE2
1613         .IFDEF EXTENDED_ASM
1614             MOV #0,&RPT_WORD        ; clear RPT instruction
1615         .ENDIF
1616             JMP ASSEMBLER           ; add ASSEMBLER in CONTEXT stack
1617
1618 ; HDNCODE (hidden CODE) is used to define a CODE word which must not to be executed by FORTH interpreter
1619 ; i.e. typically an assembler word called by CALL and ended by RET, or an interrupt routine ended by RETI.
1620 ; HDNCODE words are only usable in ASSEMBLER definitions.
1621             FORTHWORD "HDNCODE"
1622             MOV #BODYASSEMBLER,&CURRENT ; select ASSEMBLER word set to link this HDNCODE definition
1623             JMP ASMCODE
1624
1625             asmword "ENDCODE"       ; test PSP balancing then restore previous CONTEXT
1626 ENDCODE     mDOCOL                  ; and set CURRENT = CONTEXT (to also terminate HDNCODE definitions)
1627             .word   QREVEAL
1628             mNEXTADR
1629             MOV @RSP+,IP
1630 ENDCODEND   MOV &CONTEXT+2,&CURRENT ;5 to do DEFINITIONS (before previous)
1631             JMP PREVIOUS            ;
1632
1633             FORTHWORD "CODENNM"     ; CODENoNaMe is the assembly counterpart of :NONAME
1634 CODENNM     PUSH #ASMCODE1          ; define HEADERLESS return
1635             JMP HEADERLESS          ; that makes room for CFA and PFA
1636
1637 ; here are 3 words used to switch FORTH <--> ASSEMBLER
1638
1639 ; COLON --      compile DOCOL, remove ASSEMBLER from CONTEXT and CURRENT, switch to compilation state
1640             asmword "COLON"
1641             MOV &DP,W
1642         .SWITCH DTC
1643         .CASE 1
1644             MOV #DOCOL,0(W)         ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL)
1645             ADD #2,&DP
1646         .CASE 2
1647             MOV #120Dh,0(W)         ; compile PUSH IP
1648 COLON1      MOV #DOCOL,2(W)         ; compile CALL R4 = rDOCOL
1649             ADD #4,&DP
1650         .CASE 3 ; inlined DOCOL
1651             MOV #120Dh,0(W)         ; compile PUSH IP
1652 COLON1      MOV #400Dh,2(W)         ; compile MOV PC,IP
1653             MOV #522Dh,4(W)         ; compile ADD #4,IP
1654             MOV #4D30h,6(W)         ; compile MOV @IP+,PC
1655             ADD #8,&DP              ;
1656         .ENDCASE ; DTC
1657 COLON2      MOV #-1,&STATE          ;3 enter in compile state
1658             JMP ENDCODEND           ;2 to do PREVIOUS DEFINITIONS
1659
1660 ; LO2HI --       same as COLON but without saving IP
1661             asmword "LO2HI"
1662         .SWITCH DTC
1663         .CASE 1                     ; compile 2 words
1664             MOV &DP,W
1665             MOV #12B0h,0(W)         ; compile CALL #EXIT, 2 words  4+6=10~
1666             MOV #EXIT,2(W)
1667             ADD #4,&DP
1668             JMP COLON2
1669         .ELSECASE                   ; CASE 2 : compile 1 word, CASE 3 : compile 3 words
1670             SUB #2,&DP              ; to skip PUSH IP
1671             MOV &DP,W
1672             JMP COLON1
1673         .ENDCASE
1674
1675 ; HI2LO --       immediate, switch to low level, set interpretation state, add ASSEMBLER to CONTEXT
1676             FORTHWORDIMM "HI2LO"    ;
1677             ADD #2,&DP              ; HERE+2
1678             MOV &DP,W               ; W = HERE+2
1679             MOV W,-2(W)             ; compile HERE+2 to HERE
1680             MOV #0,&STATE           ; LEFTBRACKET
1681             JMP ASMCODE2            ; add ASSEMBLER in context
1682
1683 ;-------------------------------------------------------------------------------
1684 ; WORDS SET for VOCABULARY, not ANS compliant,
1685 ;-------------------------------------------------------------------------------
1686     .IFDEF VOCABULARY_SET
1687             FORTHWORD "WORDSET"
1688 ;X VOCABULARY       -- create a new word_set
1689 VOCABULARY  mDOCOL
1690             .word   CREATE
1691         .SWITCH THREADS
1692         .CASE   1
1693             .word   lit,0,COMMA     ; W = DP
1694             mNEXTADR                ;
1695         .ELSECASE
1696             mNEXTADR                ; W = DP
1697             MOV #THREADS,X          ; count
1698 VOCABULOOP  MOV #0,0(W)             ; DP = BODY first
1699             ADD #2,W
1700             SUB #1,X
1701             JNZ VOCABULOOP
1702         .ENDCASE                    ; W = DP
1703             MOV &LASTVOC,0(W)
1704             MOV W,&LASTVOC
1705             ADD #2,W
1706             MOV W,&DP               ; update DP
1707             mASM2FORTH
1708             .word   DOES
1709     .ENDIF ; VOCABULARY_SET
1710 VOCDOES     mNEXTADR                ; adds WORD-SET first in context stack
1711     .IFDEF VOCABULARY_SET
1712 ALSO        MOV #7,Y                ;2 -- move up 7 words, first word in last
1713             MOV #CONTEXT+12,X       ;2 X=src
1714 ALSOLOOP    MOV @X,2(X)             ; X=src < Y=dst copy W bytes beginning with the end
1715             SUB #2,X
1716             SUB #1,Y
1717             JNZ ALSOLOOP
1718     .ELSE ; VOCABULARY_SET off      ; VOCDOES is used only by the assembler to switch from HIlevel to LOlevel environments
1719            MOV #BODYFORTH,&CONTEXT+2;4  copy BODYFORTH      --> 2th cell of CONTEXT
1720     .ENDIF ; VOCABULARY_SET
1721             MOV TOS,&CONTEXT        ;3  copy word-set BODY  --> first cell of CONTEXT
1722             MOV #DROPEXIT,PC
1723
1724     .IFDEF VOCABULARY_SET
1725             FORTHWORD "FORTH"
1726     .ENDIF
1727 ;X  FORTH    --                     ; add FORTH as first context word-set
1728 FORTH                               ; leave BODYFORTH on the stack and run VOCDOES
1729             CALL rDODOES            ; Code Field Address (CFA) of FORTH
1730 PFAFORTH    .word   VOCDOES         ; Parameter Field Address (PFA) of FORTH
1731 BODYFORTH   .word   lastforthword   ; BODY of FORTH
1732     .SWITCH THREADS
1733     .CASE   2
1734             .word   lastforthword1
1735     .CASE   4
1736             .word   lastforthword1
1737             .word   lastforthword2
1738             .word   lastforthword3
1739     .CASE   8
1740             .word   lastforthword1
1741             .word   lastforthword2
1742             .word   lastforthword3
1743             .word   lastforthword4
1744             .word   lastforthword5
1745             .word   lastforthword6
1746             .word   lastforthword7
1747     .CASE   16
1748             .word   lastforthword1
1749             .word   lastforthword2
1750             .word   lastforthword3
1751             .word   lastforthword4
1752             .word   lastforthword5
1753             .word   lastforthword6
1754             .word   lastforthword7
1755             .word   lastforthword8
1756             .word   lastforthword9
1757             .word   lastforthword10
1758             .word   lastforthword11
1759             .word   lastforthword12
1760             .word   lastforthword13
1761             .word   lastforthword14
1762             .word   lastforthword15
1763     .CASE   32
1764             .word   lastforthword1
1765             .word   lastforthword2
1766             .word   lastforthword3
1767             .word   lastforthword4
1768             .word   lastforthword5
1769             .word   lastforthword6
1770             .word   lastforthword7
1771             .word   lastforthword8
1772             .word   lastforthword9
1773             .word   lastforthword10
1774             .word   lastforthword11
1775             .word   lastforthword12
1776             .word   lastforthword13
1777             .word   lastforthword14
1778             .word   lastforthword15
1779             .word   lastforthword16
1780             .word   lastforthword17
1781             .word   lastforthword18
1782             .word   lastforthword19
1783             .word   lastforthword20
1784             .word   lastforthword21
1785             .word   lastforthword22
1786             .word   lastforthword23
1787             .word   lastforthword24
1788             .word   lastforthword25
1789             .word   lastforthword26
1790             .word   lastforthword27
1791             .word   lastforthword28
1792             .word   lastforthword29
1793             .word   lastforthword30
1794             .word   lastforthword31
1795     .ELSECASE
1796     .ENDCASE
1797             .word   voclink
1798 voclink     .set    $-2
1799
1800     .IFDEF VOCABULARY_SET
1801 ;            FORTHWORD "ASSEMBLER"
1802             FORTHWORD "hidden"  ; cannot be found by FORTH interpreter because the string is not capitalized
1803     .ENDIF
1804 ;X  ASSEMBLER       --          ; add ASSEMBLER as first context word-set
1805 ASSEMBLER   CALL rDODOES        ; leave BODYASSEMBLER on the stack and run VOCDOES
1806             .word   VOCDOES
1807 BODYASSEMBLER   .word   lastasmword
1808     .SWITCH THREADS
1809     .CASE   2
1810             .word   lastasmword1
1811     .CASE   4
1812             .word   lastasmword1
1813             .word   lastasmword2
1814             .word   lastasmword3
1815     .CASE   8
1816             .word   lastasmword1
1817             .word   lastasmword2
1818             .word   lastasmword3
1819             .word   lastasmword4
1820             .word   lastasmword5
1821             .word   lastasmword6
1822             .word   lastasmword7
1823     .CASE   16
1824             .word   lastasmword1
1825             .word   lastasmword2
1826             .word   lastasmword3
1827             .word   lastasmword4
1828             .word   lastasmword5
1829             .word   lastasmword6
1830             .word   lastasmword7
1831             .word   lastasmword8
1832             .word   lastasmword9
1833             .word   lastasmword10
1834             .word   lastasmword11
1835             .word   lastasmword12
1836             .word   lastasmword13
1837             .word   lastasmword14
1838             .word   lastasmword15
1839     .CASE   32
1840             .word   lastasmword1
1841             .word   lastasmword2
1842             .word   lastasmword3
1843             .word   lastasmword4
1844             .word   lastasmword5
1845             .word   lastasmword6
1846             .word   lastasmword7
1847             .word   lastasmword8
1848             .word   lastasmword9
1849             .word   lastasmword10
1850             .word   lastasmword11
1851             .word   lastasmword12
1852             .word   lastasmword13
1853             .word   lastasmword14
1854             .word   lastasmword15
1855             .word   lastasmword16
1856             .word   lastasmword17
1857             .word   lastasmword18
1858             .word   lastasmword19
1859             .word   lastasmword20
1860             .word   lastasmword21
1861             .word   lastasmword22
1862             .word   lastasmword23
1863             .word   lastasmword24
1864             .word   lastasmword25
1865             .word   lastasmword26
1866             .word   lastasmword27
1867             .word   lastasmword28
1868             .word   lastasmword29
1869             .word   lastasmword30
1870             .word   lastasmword31
1871     .ELSECASE
1872     .ENDCASE
1873             .word   voclink
1874 voclink     .set    $-2
1875
1876     .IFDEF VOCABULARY_SET
1877             FORTHWORD "PREVIOUS"
1878 ;X  PREVIOUS   --               pop first word-set out of context stack
1879 PREVIOUS    MOV #8,Y                ;1 move down 8 words, first with CONTEXT+2 addr, end when NULL_WORD is moved
1880             MOV #CONTEXT+2,X        ;2 X = CONTEXT+2 = org, X-2 = CONTEXT = dst
1881 PREVIOUSLOO CMP #0,0(X)             ;3 [org] = 0 ?
1882             JZ PREVIOUSEND          ;2 to avoid scratch of the first CONTEXT cell by human mistake, then to skip useless loops
1883             MOV @X+,-4(X)           ;4
1884             SUB #1,Y                ;1
1885             JNZ PREVIOUSLOO         ;2 7~ loop * 8 = 56 ~
1886 PREVIOUSEND MOV @IP+,PC             ;4
1887     .ELSE                           ;
1888 PREVIOUS    MOV #BODYFORTH,&CONTEXT
1889 ONLY        MOV #0,&CONTEXT+2       ; then execute ONLY
1890             MOV @IP+,PC
1891     .ENDIF ; VOCABULARY_SET
1892
1893     .IFDEF VOCABULARY_SET
1894             FORTHWORD "ONLY"
1895 ;X ONLY     --      cut the context stack to access only the first word-set, ex.: FORTH ONLY
1896 ONLY        MOV #0,&CONTEXT+2
1897             MOV @IP+,PC
1898
1899             FORTHWORD "DEFINITIONS"
1900 ;X DEFINITIONS  --      set last context vocabulary as entry for further defining words
1901 DEFINITIONS MOV &CONTEXT,&CURRENT
1902             MOV @IP+,PC
1903     .ENDIF ; VOCABULARY_SET
1904
1905 ;-------------------------------------------------------------------------------
1906 ; FASTFORTH environment management: DP, LASTVOC, CURRENT, CONTEXT and THREADS
1907 ;-------------------------------------------------------------------------------
1908 ENV_COPY
1909     .IFDEF VOCABULARY_SET
1910             MOV #24,T               ; bytes count of extended RST environment: DP,LASTVOC,CURRENT,CONTEXT(8),null_word
1911     .ELSE
1912             MOV #10,T               ; bytes count of RST environment: DP,LASTVOC,CURRENT,CONTEXT(2)
1913     .ENDIF
1914 ENV_LOOP    MOV @X+,0(W)
1915             ADD #2,W
1916             SUB #2,T                ; words-1
1917             JNZ ENV_LOOP
1918             MOV @RSP+,PC
1919
1920             FORTHWORD "RST_SET"     ; define actual environment as new RESET environment
1921 RST_SET     MOV #DP,X               ; org = RAM value (DP first)
1922             MOV #RST_DP,W           ; dst = FRAM value (RST_DP first), see \inc\ThingsInFirst.inc
1923             CALL #ENV_COPY          ; copy environment RAM --> FRAM RST, use T,W,X
1924             MOV @IP+,PC
1925
1926             FORTHWORD "RST_RET"     ; init / return_to_previous RESET or MARKER environment
1927 RST_RET     MOV #RST_DP,X           ; org = FRAM value (first RST_DP), see \inc\ThingsInFirst.inc
1928             MOV @X,S                ; S = restored DP, used below for comparaison with NFAs
1929             MOV #DP,W               ; dst = RAM value (first DP)
1930             CALL #ENV_COPY          ; copy environment FRAM RST --> RAM, use T,W,X
1931 ;-----------------------------------;
1932             MOV &LASTVOC,W          ; W = init/restored LASTVOC
1933     .SWITCH THREADS                 ; init/restore THREAD(s) with NFAs value < init/restored DP, for all word set
1934     .CASE   1 ; mono thread word-set
1935 MARKALLVOC  MOV W,Y                 ; W=VLK   Y = VLK
1936 MRKWORDLOOP MOV -2(Y),Y             ; W=VLK   Y = [THD_n] then [LFA] = NFA
1937             CMP Y,S                 ; Y=NFA   S=DP        CMP = S-Y : OLD_DP-NFA
1938             JNC MRKWORDLOOP         ; loop back if S<Y : OLD_DP<NFA
1939             MOV Y,-2(W)             ; W=VLK   X=THD   Y=NFA   refresh thread with good NFA
1940     .ELSECASE ; multi threads word-set
1941 MARKALLVOC  MOV #THREADS,T          ; S=DP     T=ThdCnt (Threads Count), VLK = THD_n+1
1942             MOV W,X                 ; W = VLK   X = VLK then THD_n (VOCLINK first, then THREADn)
1943 MRKTHRDLOOP MOV X,Y                 ;
1944             SUB #2,X                ;
1945 MRKWORDLOOP MOV -2(Y),Y             ; Y = NFA = [THD_n] then [LFA]
1946             CMP Y,S                 ; Y = NFA   S=DP       CMP = S-Y : DP-NFA
1947             JNC MRKWORDLOOP         ;           loop back if S<Y : DP<NFA (if not_carry = if borrow)
1948 MARKTHREAD  MOV Y,0(X)              ; Y=NFA     X=THD_n   refresh thread with good NFA
1949             SUB #1,T                ; T=ThdCnt-1
1950             JNZ MRKTHRDLOOP         ;           loopback to process NFA of next thread (thread-1)
1951     .ENDCASE ; of THREADS           ;
1952             MOV @W,W                ; W=[VLK] = VLK-1
1953             CMP #0,W                ;                   end of vocs ?
1954             JNZ MARKALLVOC          ; W=VLK-1           no : loopback
1955             MOV @IP+,PC             ;
1956
1957 ;-------------------------------------------------------------------------------
1958 ; PUC 7 : SELECT RST_RET|DEEP_RESET <== INIT_FORTH <== (PUC,SYS,QABORT)
1959 ;-------------------------------------------------------------------------------
1960 SEL_RST_DEP CMP #0,TOS              ;
1961             JGE RST_RET             ; if TOS >= 0
1962 ;-----------------------------------;
1963 ; DEEP RESET                        ; if TOS < 0
1964 ;-----------------------------------;
1965 ; DEEP INIT SIGNATURES AREA         ;
1966 ;-----------------------------------;
1967             MOV #16,X               ; max known SIGNATURES length = 12 bytes
1968 SIGNATLOOP  SUB #2,X                ;
1969             MOV #-1,SIGNATURES(X)   ; reset signatures; WARNING ! DON'T CHANGE IMMEDIATE VALUE !
1970             JNZ SIGNATLOOP          ;
1971 ;-----------------------------------;
1972 ; DEEP INIT VECTORS INT             ; X = 0 ;-)
1973 ;-----------------------------------;
1974             MOV #RESET,-2(X)        ; write RESET at addr X-2 = FFFEh
1975 INIVECLOOP  SUB #2,X                ;
1976             MOV #COLD,-2(X)         ; -2(X) = FFFCh first
1977             CMP #0FFACh+2,X         ; init 41 vectors, FFFCh down to 0FFACh
1978             JNZ INIVECLOOP          ; all vectors are initialised to execute COLD routine
1979 ;-----------------------------------;
1980 ; DEEP INIT Terminal Int vector     ;
1981 ;-----------------------------------;
1982             MOV #DEEP_ORG,X         ; DEEP_ORG values are in FRAM INFO, see \inc\ThingsInFirst.inc
1983             MOV @X+,&TERM_VEC       ; TERMINAL_INT           as default vector       --> FRAM TERM_VEC
1984 ;-----------------------------------;
1985 ; DEEP INIT FRAM RST values         ; 8 word values
1986 ;-----------------------------------;
1987             MOV #RST_LEN,T          ; bytes count
1988             MOV #RST_ORG,W          ; W = dst, X = org
1989             CALL #ENV_LOOP          ;
1990             MOV #0,&RST_CONTEXT+2   ; to do FORTH ONLY
1991 ;-----------------------------------;
1992 ; WARM INIT threads of all word set ;
1993 ;-----------------------------------;
1994             JMP RST_RET             ; then go to DUP|PUCNEXT,  resp. in QABORT|RESET
1995 ;-----------------------------------;
1996
1997 ; https://forth-standard.org/standard/core/MARKER
1998 ; MARKER
1999 ;name Execution: ( -- )
2000 ;Restore all dictionary allocation and search order pointers to the state they had just prior to the
2001 ;definition of name. Remove the definition of name and all subsequent definitions. Restoration
2002 ;of any structures still existing that could refer to deleted definitions or deallocated data space is
2003 ;not necessarily provided. No other contextual information such as numeric base is affected.
2004
2005 ; FastForth provides all that is necessary for a real time application with MARKER definition,
2006 ; by adding a call to a custom subroutine to restore all user environment.
2007 ; the FORTH environment is it automaticaly restored.
2008 MARKER_DOES                         ; restores RST environment saved by MARKER defn.,
2009                                     ; executes user defined subroutine (RET_ADR by default),
2010                                     ; then executes RST_RET.
2011             mNEXTADR                ; -- BODY
2012     .IFDEF VOCABULARY_SET
2013             MOV TOS,X               ;                       X = org (first : BODY=MARKER_DP)
2014             MOV #RST_DP,W           ;                       W = dst (first : RST_DP), see \inc\ThingsInFirst.inc
2015             CALL #ENV_COPY          ;                       copy FORTH environment FRAM MARKER --> FRAM RST
2016             MOV X,TOS               ; -- RET_ADR            by default
2017     .ELSE
2018             MOV @TOS+,&RST_DP       ;
2019     .ENDIF
2020             CALL @TOS+              ; -- USER_BODY          executes user defined asm subroutine (RET_ADR by default), IP and TOS are free
2021             MOV @PSP+,TOS           ; --
2022             MOV @RSP+,IP            ;
2023             JMP RST_RET             ;                       then performs RST_RET
2024
2025             FORTHWORD "MARKER"      ; definition part
2026 ;( "<spaces>name" -- )
2027 ;Skip leading space delimiters. Parse name delimited by a space. Create a definition for name
2028 ;with the execution semantics defined above.
2029 ;-------------------------------------------------------------------------------
2030 ;before that, it execute DOES part of previous definition if already exists.
2031             PUSH &TOIN
2032             mDOCOL
2033             .word BL,WORDD,FIND
2034             .word QFBRAN,MARKER_NEXT
2035             .word DUP,EXECUTE
2036 MARKER_NEXT mNEXTADR
2037             MOV @PSP+,TOS           ;
2038             MOV @RSP+,IP
2039             MOV @RSP+,&TOIN
2040 ;-------------------------------------------------------------------------------
2041             CALL #HEADER            ;4                  W = DP, Y = NFA,
2042             MOV #1285h,-4(W)        ;4                  CFA = CALL rDODOES
2043             MOV #MARKER_DOES,-2(W)  ;4                  PFA = MARKER_DOES
2044             SUB #2,Y                ;1                  Y = NFA-2 = LFA = DP to be restored, W = FRAM MARKER_DDP
2045     .IFDEF VOCABULARY_SET
2046             MOV Y,&DP               ;                   Y = previous DP (just before MARKER definition)
2047             MOV #DP,X               ;                   X = org = RAM DP, W = dst = MARKER_BODY
2048             CALL #ENV_COPY          ;                   copy environment RAM --> FRAM MARKER
2049             MOV #RET_ADR,0(W)       ;4                  user defined subroutine by default = RET_ADR
2050             ADD #2,W                ;1
2051             MOV W,&DP               ;4                  set new RAM DP (after the end of MARKER definition)
2052     .ELSE
2053             MOV Y,0(W)              ;                   DP to be restored
2054             MOV #RET_ADR,2(W)       ;                   MARKER subroutine
2055             ADD #4,&DP              ;
2056     .ENDIF
2057 LINK_NFA    MOV &LAST_NFA,Y         ;                   if no error, link this definition in its thread
2058             MOV &LAST_THREAD,X      ;
2059 REVEAL      MOV @X,-2(Y)            ; [LAST_THREAD] --> LFA         (for NONAME: LFA --> 210h unused PA reg)
2060             MOV Y,0(X)              ; LAST_NFA --> [LAST_THREAD]    (for NONAME: [LAST_THREAD] --> 212h unused PA reg)
2061 REVEAL_END  MOV @IP+,PC
2062
2063 ;===============================================================================
2064 ; ASSEMBLER OPTION
2065 ;===============================================================================
2066     .IFDEF EXTENDED_ASM
2067         .include "forthMSP430FR_EXTD_ASM.asm"
2068     .ELSE
2069         .include "forthMSP430FR_ASM.asm"
2070     .ENDIF
2071
2072     .IFDEF SD_CARD_LOADER
2073 ;-------------------------------------------------------------------------------
2074 ; SD CARD OPTIONS
2075 ;-------------------------------------------------------------------------------
2076         .include "forthMSP430FR_SD_LowLvl.asm"  ; SD primitives
2077         .include "forthMSP430FR_SD_INIT.asm"    ; return to INIT_TERM; without use of IP,TOS
2078         .include "forthMSP430FR_SD_LOAD.asm"    ; SD LOAD driver
2079 ;        .include "forthMSP430FR_SD_LOAD_next.asm"    ; SD LOAD driver
2080         .IFDEF SD_CARD_READ_WRITE
2081             .include "forthMSP430FR_SD_RW.asm"  ; SD Read/Write driver
2082 ;            .include "forthMSP430FR_SD_RW_next.asm"  ; SD Read/Write driver
2083         .ENDIF
2084     .ENDIF
2085 ;-------------------------------------------------------------------------------
2086 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against Deep_RST)
2087 ;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
2088 ;
2089 ;           .include "\ADDON\CORE_ANS.asm"
2090 ;           .include "\ADDON\UTILITY.asm"
2091 ;           .include "\ADDON\FIXPOINT.asm"
2092 ;           .include "YOUR_CODE.asm"
2093 ;
2094 ;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2095 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against Deep_RST)
2096 ;-------------------------------------------------------------------------------
2097
2098 ;-------------------------------------------------------------------------------
2099 ; RESOLVE ASSEMBLY PTR, init interrupt Vectors
2100 ;-------------------------------------------------------------------------------
2101     .include "ThingsInLast.inc"