forthMSP430FR.asm

   1 ; -*- coding: utf-8 -*-
   2 ;
   3 ;-------------------------------------------------------------------------------
   4 ; Vingt fois sur le métier remettez votre ouvrage,
   5 ; Polissez-le sans cesse, et le repolissez,
   6 ; Ajoutez quelquefois, et souvent effacez.               Boileau, L'Art poétique
   7 ;-------------------------------------------------------------------------------
   8
   9 ;-------------------------------------------------------------------------------
  10 ; SCITE editor: copy https://www.scintilla.org/Sc4xx.exe to \prog\scite.exe
  11 ;-------------------------------------------------------------------------------
  12 ; MACRO ASSEMBLER AS
  13 ; unzip http://john.ccac.rwth-aachen.de:8000/ftp/as/precompiled/i386-unknown-win32/aswcurr.zip
  14 ;-------------------------------------------------------------------------------
  15     .listing purecode   ; reduce listing to true conditionnal parts
  16     MACEXP_DFT noif     ; reduce macros listing to true part
  17     .PAGE  0            ;
  18 ;-------------------------------------------------------------------------------
  19
  20 VER .equ "V308"     ; FORTH version
  21
  22 ;===============================================================================
  23 ; before assembling or programming you must set TARGET in scite param1 (SHIFT+F8)
  24 ; according to the selected (uncommented) TARGET below
  25 ;===============================================================================
  26
  27 ;===============================================================================
  28 ; FAST FORTH has a minimalistic footprint to enable its use from 8k FRAM devices
  29 ; kernel size below are for 8MHz, DTC=1, THREADS=1, 4WIRES (RTS) options
  30 ;===============================================================================
  31 ;    TARGET        ;                                        ;INFO+VECTORS+ MAIN bytes
  32 ;MSP_EXP430FR5739  ; compile for MSP-EXP430FR5739 launchpad ; 64 +  128  + 2768 bytes
  33 ;MSP_EXP430FR5969  ; compile for MSP-EXP430FR5969 launchpad ; 64 +  128  + 2760 bytes
  34 ;MSP_EXP430FR5994  ; compile for MSP-EXP430FR5994 launchpad ; 64 +  128  + 2780 bytes
  35 ;MSP_EXP430FR6989  ; compile for MSP-EXP430FR6989 launchpad ; 64 +  128  + 2782 bytes
  36 ;MSP_EXP430FR4133  ; compile for MSP-EXP430FR4133 launchpad ; 64 +  128  + 2822 bytes
  37 ;MSP_EXP430FR2355  ; compile for MSP-EXP430FR2355 launchpad ; 64 +  128  + 2756 bytes
  38 ;MSP_EXP430FR2433  ; compile for MSP-EXP430FR2433 launchpad ; 64 +  128  + 2746 bytes
  39 ;LP_MSP430FR2476   ; compile for LP_MSP430FR2476  launchpad ; 64 +  128  + 2760 bytes
  40 CHIPSTICK_FR2433;  ; compile for "CHIPSTICK" of M. Ken BOAK ; 64 +  128  + 2748 bytes
  41
  42 ; choose DTC model (Direct Threaded Code); if you don't know, choose 2, because DOCOL routine without using scratch register
  43 DTC .equ 2  ; DTC model 1 : DOCOL = CALL rDOCOL           14 cycles 1 word      shortest DTC model
  44             ; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT   13 cycles 2 words     best compromize to mix FORTH/ASM code
  45             ; DTC model 3 : inlined DOCOL                  9 cycles 4 words     fastest
  46
  47 THREADS     .equ 16 ;  1,  2 ,  4 ,  8 ,  16,  32  search entries in dictionnary.
  48                     ; +0, +28, +48, +56, +90, +154 bytes, usefull to speed up compilation;
  49                     ; the FORTH interpreter is speed up by about a square root factor of THREADS.
  50
  51 FREQUENCY   .equ 1 ; fully tested at 1,2,4,8,16,24 MHz (24 MHz for MSP430FR57xx,MSP430FR2355)
  52
  53 ;===============================================================================
  54 TERMINAL_I2C  ; uncomment to select I2C_Master TERMINAL instead of UART TERMINAL
  55 ;===============================================================================
  56     .IFDEF TERMINAL_I2C
  57 MYSLAVEADR   .equ 18
  58 ;===============================================================================
  59     .ELSE ; UART TERMINAL
  60 ;===============================================================================
  61 TERMINALBAUDRATE    .equ 115200 ; choose value considering the frequency and the UART2USB bridge, see explanations below.
  62 ;-------------------------------------------------------------------------------
  63 TERMINAL3WIRES      ; + 18 bytes    enable 3 wires (GND,TX,RX) with XON/XOFF software flow control (PL2303TA/HXD, CP2102)
  64 TERMINAL4WIRES      ; + 12 bytes    enable 4 wires with hardware flow control on RX with RTS (PL2303TA/HXD, FT232RL)
  65 ;TERMINAL5WIRES      ; + 10 bytes    enable 5 wires with hardware flow control on RX/TX with RTS/CTS (PL2303TA/HXD, FT232RL)...
  66 ;-------------------------------------------------------------------------------
  67 ;HALFDUPLEX          ; switch to UART half duplex TERMINAL input
  68 ;===============================================================================
  69     .ENDIF
  70 ;===============================================================================
  71 ; MINIMAL ADDONS if you want a canonical FORTH: CORE_COMPLEMENT + CONDCOMP + PROMPT
  72 ;===============================================================================
  73 ; MINIMAL ADDONS for FAST FORTH: MSP430ASSEMBLER + CONDCOMP
  74 ;===============================================================================
  75
  76 ;-------------------------------------------------------------------------------
  77 ; KERNEL ADDONs that can't be added later
  78 ;-------------------------------------------------------------------------------
  79 MSP430ASSEMBLER     ; + 1812 bytes : adds embedded assembler with TI syntax; without, you can do all but bigger and slower...
  80 CONDCOMP            ; +  306 bytes : adds conditionnal compilation [IF] [ELSE] [THEN] [DEFINED] [UNDEFINED]
  81 DOUBLE_INPUT        ; +   56 bytes : adds the interpretation engine for double numbers (numbers with dot)
  82 FIXPOINT_INPUT      ; +   74 bytes : adds the interpretation engine for Q15.16 numbers (numbers with comma)
  83 ;DEFERRED            ; +  124 bytes : adds DEFER IS :NONAME CODENNM (CODE_No_NaMe), useful for interrupts start and stop.
  84 ;EXTENDED_MEM        ; +  740 bytes : allows assembler to execute code up to 1MB (LARGE_CODE).
  85 ;EXTENDED_ASM        ; + 1260 bytes : extended assembler to 20 bits datas (LARGE_DATA + LARGE_CODE).
  86 ;SD_CARD_LOADER      ; + 1766 bytes : to load source files from SD_card
  87 ;SD_CARD_READ_WRITE  ; + 1148 bytes : to read, create, write and del files + copy text files from PC to target SD_Card
  88 ;BOOTLOADER          ; +  132 bytes : includes in WARM process the bootloader SD_CARD\BOOT.4TH.
  89 ;VOCABULARY_SET      ; +  174 bytes : adds words: VOCABULARY FORTH ASSEMBLER ALSO PREVIOUS ONLY DEFINITIONS (FORTH83)
  90 ;PROMPT              ; +   22 bytes : to display prompt "ok "
  91 ;-------------------------------------------------------------------------------
  92
  93 ;-------------------------------------------------------------------------------
  94 ; OPTIONS that can be added later by downloading their source file              >-----------------------+
  95 ; however, added here, they are protected against WIPE and Deep Reset.                                  |
  96 ;-------------------------------------------------------------------------------                        v
  97 ;CORE_COMPLEMENT     ; + 1974 bytes : MINIMAL OPTIONS if you want a conventional FORTH              CORECOMP.f
  98 ;FIXPOINT            ; +  422/528 bytes add HOLDS F+ F- F/ F* F#S F. S>F                            FIXPOINT.f
  99 ;UTILITY             ; +  434/524 bytes (1/16threads) : add .S .RS WORDS U.R DUMP ?                 UTILITY.f
 100 ;SD_TOOLS            ; +  142 bytes for trivial DIR, FAT, CLUSTR. and SECTOR. view, (adds UTILITY)  SD_TOOLS.f
 101     .save
 102     .listing off
 103 ;===============================================================================
 104 ; Software control flow XON/XOFF configuration:
 105 ;===============================================================================
 106 ; Launchpad <-> UARTtoUSB device <-> TeraTerm TERMINAL
 107 ;        RX <-- TX
 108 ;        TX --> RX
 109 ;       GND <-> GND
 110 ;
 111 ; TERATERM config terminal:     NewLine receive : LF,
 112 ;                               NewLine transmit : CR+LF
 113 ;                               Size : 96 chars x 49 lines (adjust lines according to your display)
 114 ;
 115 ; TERATERM config serial port:  TERMINALBAUDRATE value,
 116 ;                               8 bits, no parity, 1 Stop bit,
 117 ;                               XON/XOFF flow control,
 118 ;                               delay = 0ms/line, 0ms/char
 119 ;
 120 ; don't forget to save always new TERATERM configuration !
 121
 122 ; ------------------------------------------------------------------------------
 123 ; Only two usb2uart bridges correctly handle XON / XOFF: cp2102 and pl2303.
 124 ; ------------------------------------------------------------------------------
 125 ; the best and cheapest: UARTtoUSB cable with Prolific PL2303HXD (or PL2303TA)
 126 ; works well in 3 WIRES (XON/XOFF) and 4WIRES (GND,RX,TX,RTS) config
 127 ; ------------------------------------------------------------------------------
 128 ;       PL2303TA 4 wires CABLE                         PL2303HXD 6 wires CABLE
 129 ; pads upside: 3V3,txd,rxd,gnd,5V               pads upside: gnd, 3V3,txd,rxd,5V
 130 ;    downside: cts,dcd,dsr,rts,dtr                 downside:     rts,cts
 131 ; ------------------------------------------------------------------------------
 132 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
 133 ; ------------------------------------------------------------------------------
 134 ; up to 115200  Bds  (500kHz)
 135 ; up to 230400  Bds  (1MHz)
 136 ; up to 460800  Bds  (2MHz)
 137 ; up to 921600  Bds  (4MHz)
 138 ; up to 1843200 Bds  (8MHz)
 139 ; up to 3 MBds       (12MHz,PL2303HXD with shortened cable < 20cm)
 140 ; up to 4 MBds       (16MHz,PL2303HXD with shortened cable < 20cm)
 141 ; up to 5 MBds       (20MHz,PL2303HXD with shortened cable < 20cm)
 142 ; up to 6 MBds       (24MHz,PL2303HXD with shortened cable < 20cm)
 143
 144 ; UARTtoUSB module with Silabs CP2102 (supply current = 20 mA)
 145 ; ------------------------------------------------------------------------------
 146 ; WARNING ! if you use it as supply, buy a CP2102 module with a VCC switch 5V/3V3 and swith on 3V3 !
 147 ; ------------------------------------------------------------------------------
 148 ; 9600,19200,38400 (250kHz)
 149 ; + 57600, 115200 (500kHz)
 150 ; + 134400,230400 (1MHz)
 151 ; + 460800 (2MHz)
 152 ; + 921600 (4MHz,8MHz,16MHz,24MHz)
 153
 154 ;===============================================================================
 155 ; Hardware control flow configuration: RTS is wired on UART2USB CTS pin
 156 ;===============================================================================
 157
 158 ; Launchpad <-> UARTtoUSB
 159 ;        RX <-- TX
 160 ;        TX --> RX
 161 ;       RTS --> CTS     (see launchpad.asm for RTS selected pin)
 162 ;       GND <-> GND
 163
 164 ; RTS pin may be permanently wired on SBWTCK/TEST pin without disturbing SBW 2 wires programming
 165
 166 ; TERATERM config terminal      : NewLine receive : LF,
 167 ;                                 NewLine transmit : CR+LF
 168 ;                                 Size : 96 chars x 49 lines (adjust lines to your display)
 169
 170 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 171 ;                                 8bits, no parity, 1Stopbit,
 172 ;                                 Hardware flow control,
 173 ;                                 delay = 0ms/line, 0ms/char
 174
 175 ; don't forget : save new TERATERM configuration !
 176
 177 ; notice that the control flow seems not necessary for TX (CTS <-- RTS)
 178
 179 ; UARTtoUSB module with PL2303TA/HXD
 180 ; ------------------------------------------------------------------------------
 181 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
 182 ; ------------------------------------------------------------------------------
 183 ; up to 250 kbds / MHz
 184 ; ----------------------------------
 185 ; 9600,19200,38400,57600    (250kHz)
 186 ; + 115200                  (500kHz)
 187 ; + 201600,230400,250000    (1MHz)
 188 ; + 403200,460800           (2MHz)
 189 ; + 806400,921600           (4MHz)
 190 ; + 1843200                 (8MHz)
 191 ; + 2764800                 (12MHz)
 192 ; + 4000000                 (16MHz)
 193 ; + 5000000                 (20MHz)
 194 ; + 6000000                 (24MHz)
 195
 196 ; UARTtoUSB module with FTDI FT232RL (FT230X don't work correctly)
 197 ; ------------------------------------------------------------------------------
 198 ; WARNING ! buy a FT232RL module with a switch 5V/3V3 and select 3V3 !
 199 ; ------------------------------------------------------------------------------
 200 ; 9600,19200,38400,57600,115200 (500kHz)
 201 ; + 230400 (1MHz)
 202 ; + 460800 (2MHz)
 203 ; + 921600 (4,8,16 MHz)
 204
 205 ; ------------------------------------------------------------------------------
 206 ; UARTtoBluetooth 2.0 module (RN42 sparkfun bluesmirf) at 921600bds
 207 ; ------------------------------------------------------------------------------
 208 ; 9600,19200,38400,57600,115200 (500kHz)
 209 ; + 230400 (1MHz)
 210 ; + 460800 (2MHz)
 211 ; + 921600 (4,8,16 MHz)
 212
 213 ; RN42 config : connect RN41/RN42 module on teraterm, via USBtoUART bridge,
 214 ; -----------   8n1, 115200 bds, no flow control, echo on
 215 ;               $$$         // enter control mode, response: AOK
 216 ;               SU,92       // set 921600 bds, response: AOK
 217 ;               R,1         // reset module to take effect
 218 ;
 219 ;               connect RN42 module on FastForth target
 220 ;               add new bluetooth device on windows, password=1234
 221 ;               open the created output COMx port with TERATERM at 921600bds
 222
 223
 224 ; TERATERM config terminal      : NewLine receive : LF,
 225 ;                                 NewLine transmit : CR+LF
 226 ;                                 Size : 128 chars x 49 lines (adjust lines to your display)
 227
 228 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 229 ;                                 8bits, no parity, 1Stopbit,
 230 ;                                 Hardware flow control or software flow control or ...no flow control!
 231 ;                                 delay = 0ms/line, 0ms/char
 232
 233 ; don't forget : save new TERATERM configuration !
 234
 235 ; in fact, compared to using a UART USB bridge, only the COMx port is to be updated.
 236 ; ------------------------------------------------------------------------------
 237     .restore
 238     .include "ThingsInFirst.inc" ; macros, target definitions, init FORTH variables...
 239 ;-------------------------------------------------------------------------------
 240 ; DTCforthMSP430FR5xxx RAM memory map:
 241 ;-------------------------------------------------------------------------------
 242
 243 ;---------------------------;---------
 244 ; name             words    ; comment
 245 ;---------------------------;---------
 246 ;LSTACK = L0 = LEAVEPTR     ; ----- RAM_ORG
 247                             ; |
 248 LSTACK_LEN .equ     16      ; | grows up
 249                             ; V
 250                             ; ^
 251 PSTACK_LEN .equ     48      ; | grows down
 252                             ; |
 253 ;PSTACK=S0                  ; ----- RAM_ORG + $80
 254                             ; ^
 255 RSTACK_LEN .equ     48      ; | grows down
 256                             ; |
 257 ;RSTACK=R0                  ; ----- RAM_ORG + $E0
 258
 259 ;---------------------------;---------
 260 ; names            bytes    ; comments
 261 ;---------------------------;---------
 262 ; PAD_I2CADR                ; ----- RAM_ORG + $E0
 263 ; PAD_I2CCNT                ;
 264 ; PAD                       < ----- RAM_ORG + $E4
 265                             ; |
 266 PAD_LEN     .equ    84      ; | grows up    (ans spec. : PAD >= 84 chars)
 267                             ; v
 268 ; TIB_I2CADR                ; ----- RAM_ORG + $138
 269 ; TIB_I2CCNT                ;
 270 ; TIB                       < ----- RAM_ORG + $13C
 271                             ; |
 272 TIB_LEN     .equ    84      ; | grows up    (ans spec. : TIB >= 80 chars)
 273                             ; v
 274 ; HOLDS_ORG                 < ------RAM_ORG + $190
 275                             ; ^
 276 HOLD_LEN   .equ     34      ; | grows down  (ans spec. : HOLD_LEN >= (2*n) + 2 char, with n = 16 bits/cell
 277                             ; |
 278 ; HOLD_BASE                 < ----- RAM_ORG + $1B2
 279                             ;
 280                             ;       system variables
 281                             ;
 282                             ; ----- RAM_ORG + $1E0
 283                             ;
 284                             ;       28 bytes free
 285                             ;
 286 ; SD_BUF_I2CADR             < ----- RAM_ORG + $1FC
 287 ; SD_BUF_I2CCNT             ;
 288 ; SD_BUF                    < ----- RAM_ORG + $200
 289                             ;
 290 SD_BUF_LEN   .equ   200h    ;       512 bytes buffer
 291                             ;
 292 ; SD_BUF_END                < ----- RAM_ORG + $400
 293
 294 LSTACK          .equ RAM_ORG
 295 LEAVEPTR        .equ LSTACK             ; Leave-stack pointer
 296 PSTACK          .equ LSTACK+(LSTACK_LEN*2)+(PSTACK_LEN*2)
 297 RSTACK          .equ PSTACK+(RSTACK_LEN*2)
 298 PAD_I2CADR      .equ PAD_ORG-4
 299 PAD_I2CCNT      .equ PAD_ORG-2
 300 PAD_ORG         .equ RSTACK+4
 301 TIB_I2CADR      .equ TIB_ORG-4
 302 TIB_I2CCNT      .equ TIB_ORG-2
 303 TIB_ORG         .equ PAD_ORG+PAD_LEN+4
 304 HOLDS_ORG       .equ TIB_ORG+TIB_LEN
 305
 306 HOLD_BASE       .equ HOLDS_ORG+HOLD_LEN
 307
 308 ; ----------------------------------------------------
 309 ; RAM_ORG + $1B2 : RAM VARIABLES
 310 ; ----------------------------------------------------
 311 HP              .equ HOLD_BASE      ; HOLD ptr
 312 CAPS            .equ HOLD_BASE+2    ; CAPS ON = 32, CAPS OFF = 0
 313 LAST_NFA        .equ HOLD_BASE+4    ; NFA, VOC_PFA, CFA, PSP of last created word
 314 LAST_THREAD     .equ HOLD_BASE+6    ; used by QREVEAL
 315 LAST_CFA        .equ HOLD_BASE+8
 316 LAST_PSP        .equ HOLD_BASE+10
 317 STATE           .equ HOLD_BASE+12   ; Interpreter state
 318 SOURCE          .equ HOLD_BASE+14   ; len, org of input stream
 319 SOURCE_LEN      .equ HOLD_BASE+14
 320 SOURCE_ORG      .equ HOLD_BASE+16
 321 TOIN            .equ HOLD_BASE+18   ; CurrentInputBuffer pointer
 322 DDP             .equ HOLD_BASE+20   ; dictionnary pointer
 323 LASTVOC         .equ HOLD_BASE+22   ; keep VOC-LINK
 324 CONTEXT         .equ HOLD_BASE+24   ; CONTEXT dictionnary space (8 CELLS)
 325 CURRENT         .equ HOLD_BASE+40   ; CURRENT dictionnary ptr
 326 BASE            .equ HOLD_BASE+42
 327 LINE            .equ HOLD_BASE+44   ; line in interpretation (see NOECHO, ECHO)
 328
 329 ; --------------------------;
 330 ; RAM_ORG + $1E0 : free use ;
 331 ; --------------------------;
 332     .IFDEF SD_CARD_LOADER
 333 ; --------------------------------------------------
 334 ; RAM_ORG + $1FC : RAM SD_CARD SD_BUF 4 + 512 bytes
 335 ; --------------------------------------------------
 336 SD_BUF_I2CADR   .equ SD_BUF-4
 337 SD_BUF_I2CCNT   .equ SD_BUF-2
 338 SD_BUF          .equ HOLD_BASE+78
 339 SD_BUF_END      .equ SD_BUF + 200h   ; 512bytes
 340     .ENDIF
 341
 342     .org    INFO_ORG
 343 ;-------------------------------------------------------------------------------
 344 ; INFO(DCBA) >= 256 bytes memory map (FRAM) :
 345 ;-------------------------------------------------------------------------------
 346 ; FRAM INFO: KERNEL INIT CONSTANTS and VARIABLES
 347 ; ----------------------------------------------
 348 FREQ_KHZ        .word FREQUENCY*1000    ; used to stabilize MCLK before start, see MSP430FRxxxx.asm
 349     .IFDEF TERMINAL_I2C
 350 I2CSLAVEADR     .word MYSLAVEADR        ; on MSP430FR2xxx devices with BSL I2C, Slave address is FFA0h
 351 I2CSLAVEADR1    .word 0
 352 LPM_MODE        .word GIE+LPM4          ; LPM4 is the default mode for I2C TERMINAL
 353     .ELSE ; TERMINAL_UART
 354 TERMBRW_RST     .word TERMBRW_INI       ; set by TERMINALBAUDRATE.inc
 355 TERMMCTLW_RST   .word TERMMCTLW_INI     ; set by TERMINALBAUDRATE.inc
 356 LPM_MODE        .word GIE+LPM0          ; LPM0 is the default mode for UART TERMINAL
 357     .ENDIF
 358 RSTIV_MEM       .word -7                ; to do RESET = -3 when compiling new kernel
 359 RST_DP          .word ROMDICT           ; define RST_STATE
 360 RST_VOC         .word lastvoclink       ; define RST_STATE
 361 FORTHVERSION  .word VAL(SUBSTR(VER,1,0)); used by WARM
 362 INI_THREAD      .word THREADS           ; used by FF_SPECS.f, UTILITY.f
 363 FORTHADDON      .word FADDON            ; used by FF_SPECS.f and to secure donwloading of any application.f files.
 364 ; --------------------------------------;
 365 WIPE_INI                                ; MOV #WIPE_INI,X       ; WIPE_INI constants are in FRAM INFO= DEEP_RESET init
 366 ; --------------------------------------;
 367     .IFNDEF SD_CARD_LOADER
 368 WIPE_COLD       .word COLD_TERM         ; MOV @X+,&PFACOLD      ; COLD_TERM     --> PFACOLD
 369 WIPE_INI_FORTH  .word RET_ADR           ; MOV @X+,&PFA_INI_FORTH; RET_ADR       --> PFA_INI_FORTH
 370 WIPE_SLEEP      .word RXON              ; MOV @X+,&PFASLEEP     ; RXON          --> PFASLEEP
 371 WIPE_WARM       .word INIT_TERM         ; MOV @X+,&PFAWARM      ; INIT_TERM     --> PFAWARM
 372     .ELSE
 373 WIPE_COLD       .word COLD_TERM         ; MOV @X+,&PFACOLD      ; COLD_TERM     --> PFACOLD
 374 WIPE_INI_FORTH  .word INI_SOFT_SD       ; MOV @X+,&PFA_INI_FORTH; INI_SOFT_SD   --> PFA_INI_FORTH
 375 WIPE_SLEEP      .word RXON              ; MOV @X+,&PFASLEEP     ; RXON          --> PFASLEEP
 376 WIPE_WARM       .word INI_HARD_SD       ; MOV @X+,&PFAWARM      ; INI_HARD_SD   --> PFAWARM
 377     .ENDIF
 378 WIPE_TERM_INT   .word TERMINAL_INT      ; MOV @X+,&TERM_VEC     ; TERMINAL_INT  --> TERM_VEC
 379 WIPE_DP         .word ROMDICT           ; MOV @X+,&RST_DP       ; ROMDICT       --> RST_DP
 380 WIPE_VOC        .word lastvoclink       ; MOV @X+,&RST_VOC      ; lastvoclink   --> RST_VOC
 381 ; --------------------------------------;
 382 INI_FORTH_INI                           ; MOV #INI_FORTH_INI,X, to reset all kernel variables
 383 ; --------------------------------------;
 384 INI_FORTH_ACCEPT    .word BODYACCEPT    ; MOV @X+,&PFAACCEPT    ; BODYACCEPT    --> PFAACCEPT
 385 INI_FORTH_CR        .word BODYCR        ; MOV @X+,&PFACR        ; BODYCR        --> PFACR
 386 INI_FORTH_EMIT      .word BODYEMIT      ; MOV @X+,&PFAEMIT      ; BODYEMIT      --> PFAEMIT
 387 INI_FORTH_KEY       .word BODYKEY       ; MOV @X+,&PFAKEY       ; BODYKEY       --> PFAKEY
 388 INI_FORTH_CIB       .word TIB_ORG       ; MOV @X+,&CIB_ADR      ; TIB_ORG       --> CIB_ADR
 389 ; --------------------------------------;
 390 HALF_FORTH_INI                          ; MOV #HALF_FORTH_INI,X to preserve defered words
 391 ; --------------------------------------;
 392     .SWITCH DTC
 393         .CASE 1
 394 INI_FORTH_COL   .word xDOCOL            ; MOV @X+,rDOCOL        ; init rDOCOL   (R4)
 395         .CASE 2
 396 INI_FORTH_COL   .word EXIT              ; MOV @X+,rDOCOL        ; init rDOCOL   (R4)
 397         .CASE 3
 398                 .word 0                 ; MOV @X+,R4            ; rDOCOL doesn't exist
 399     .ENDCASE
 400 INI_FORTH_DOES  .word xDODOES           ; MOV @X+,rDODOES       ; init rDODOES  (R5)
 401 INI_FORTH_CON   .word xDOCON            ; MOV @X+,rDOCON        ; init rDOCON   (R6)
 402 INI_FORTH_VAR   .word RFROM             ; MOV @X+,rDOVAR        ; init rDOVAR   (R7)
 403 INI_FORTH_CAPS  .word 32                ; MOV @X+,&CAPS         ; 32            --> CAPS
 404 INI_FORTH_BASE  .word 10                ; MOV @X+,&BASE         ; 10            --> BASE
 405 ; --------------------------------------;
 406 USER_END        .word 0
 407                 .word 0
 408                 .word 0
 409                 .word 0
 410
 411
 412     .IFDEF SD_CARD_LOADER
 413 ; ---------------------------------------
 414 ; VARIABLES that should be in RAM
 415 ; ---------------------------------------
 416         .IF RAM_LEN < 2048              ; if RAM < 2K (FR57xx) the variables below are in INFO space (FRAM)
 417 SD_ORG     .equ INFO_ORG+5Ah            ;
 418         .ELSE                           ; if RAM >= 2k the variables below are in RAM
 419 SD_ORG     .equ SD_BUF_END+2            ; 1 word guard
 420         .ENDIF
 421
 422     .org SD_ORG
 423 ; ---------------------------------------
 424 ; FAT FileSystemInfos
 425 ; ---------------------------------------
 426 FATtype         .equ SD_ORG+0
 427 BS_FirstSectorL .equ SD_ORG+2           ; init by SD_Init, used by RW_Sector_CMD
 428 BS_FirstSectorH .equ SD_ORG+4           ; init by SD_Init, used by RW_Sector_CMD
 429 OrgFAT1         .equ SD_ORG+6           ; init by SD_Init,
 430 FATSize         .equ SD_ORG+8           ; init by SD_Init,
 431 OrgFAT2         .equ SD_ORG+10          ; init by SD_Init,
 432 OrgRootDIR      .equ SD_ORG+12          ; init by SD_Init, (FAT16 specific)
 433 OrgClusters     .equ SD_ORG+14          ; init by SD_Init, Sector of Cluster 0
 434 SecPerClus      .equ SD_ORG+16          ; init by SD_Init, byte size
 435
 436 ; ---------------------------------------
 437 ; SD command
 438 ; ---------------------------------------
 439 SD_LOW_LEVEL    .equ SD_ORG+18
 440 SD_CMD_FRM      .equ SD_LOW_LEVEL       ; SD_CMDx inverted frame ${CRC7,ll,LL,hh,HH,CMD}
 441 SectorL         .equ SD_LOW_LEVEL+6
 442 SectorH         .equ SD_LOW_LEVEL+8
 443 ; ---------------------------------------
 444 ; SD_BUF management
 445 ; ---------------------------------------
 446 BufferPtr       .equ SD_LOW_LEVEL+10
 447 BufferLen       .equ SD_LOW_LEVEL+12
 448 ; ---------------------------------------
 449 ; FAT entry
 450 ; ---------------------------------------
 451 SD_FAT_LEVEL    .equ SD_LOW_LEVEL+14
 452 ClusterL        .equ SD_FAT_LEVEL       ;
 453 ClusterH        .equ SD_FAT_LEVEL+2     ;
 454 NewClusterL     .equ SD_FAT_LEVEL+4     ;
 455 NewClusterH     .equ SD_FAT_LEVEL+6     ;
 456 CurFATsector    .equ SD_FAT_LEVEL+8     ; current FATSector of last free cluster
 457 ; ---------------------------------------
 458 ; DIR entry
 459 ; ---------------------------------------
 460 DIRClusterL     .equ SD_FAT_LEVEL+10    ; contains the Cluster of current directory ; = 1 as FAT16 root directory
 461 DIRClusterH     .equ SD_FAT_LEVEL+12    ; contains the Cluster of current directory ; = 1 as FAT16 root directory
 462 EntryOfst       .equ SD_FAT_LEVEL+14
 463 ; ---------------------------------------
 464 ; Handle Pointer
 465 ; ---------------------------------------
 466 CurrentHdl      .equ SD_FAT_LEVEL+16    ; contains the address of the last opened file structure, or 0
 467 ; ---------------------------------------
 468 ; Load file operation
 469 ; ---------------------------------------
 470 pathname        .equ SD_FAT_LEVEL+18    ; start address
 471 EndOfPath       .equ SD_FAT_LEVEL+20    ; end address
 472 ; ---------------------------------------
 473 ; Handle structure
 474 ; ---------------------------------------
 475 FirstHandle     .equ SD_FAT_LEVEL+22
 476 ; three handle tokens :
 477 ; HDLB_Token= 0 : free handle
 478 ;           = 1 : file to read
 479 ;           = 2 : file updated (write)
 480 ;           =-1 : LOAD"ed file (source file)
 481
 482 ; offset values
 483 HDLW_PrevHDL    .equ 0  ; previous handle
 484 HDLB_Token      .equ 2  ; token
 485 HDLB_ClustOfst  .equ 3  ; Current sector offset in current cluster (Byte)
 486 HDLL_DIRsect    .equ 4  ; Dir SectorL
 487 HDLH_DIRsect    .equ 6  ; Dir SectorH
 488 HDLW_DIRofst    .equ 8  ; SD_BUF offset of Dir entry
 489 HDLL_FirstClus  .equ 10 ; File First ClusterLo (identify the file)
 490 HDLH_FirstClus  .equ 12 ; File First ClusterHi (identify the file)
 491 HDLL_CurClust   .equ 14 ; Current ClusterLo
 492 HDLH_CurClust   .equ 16 ; Current ClusterHi
 493 HDLL_CurSize    .equ 18 ; written size / not yet read size (Long)
 494 HDLH_CurSize    .equ 20 ; written size / not yet read size (Long)
 495 HDLW_BUFofst    .equ 22 ; SD_BUF offset ; used by LOAD"
 496 HDLW_PrevLEN    .equ 24 ; previous LEN
 497 HDLW_PrevORG    .equ 26 ; previous ORG
 498
 499     .IF RAM_LEN < 2048     ; due to the lack of RAM, only 4 handles and PAD replaces SDIB
 500 HandleMax       .equ 4 ; and not 8 to respect INFO size (FRAM)
 501 HandleLenght    .equ 28
 502 HandlesLen      .equ handleMax*HandleLenght
 503 HandleEnd       .equ FirstHandle+handleMax*HandleLenght
 504 SD_END          .equ HandleEnd
 505 SDIB_I2CADR     .equ PAD_ORG-4
 506 SDIB_I2CCNT     .equ PAD_ORG-2
 507 SDIB_ORG        .equ PAD_ORG
 508     .ELSE      ; RAM_Size >= 2k all is in RAM
 509 HandleMax       .equ 8
 510 HandleLenght    .equ 28
 511 HandlesLen      .equ handleMax*HandleLenght
 512 HandleEnd       .equ FirstHandle+handleMax*HandleLenght
 513 SDIB_I2CADR     .equ SDIB_ORG-4
 514 SDIB_I2CCNT     .equ SDIB_ORG-2
 515 SDIB_ORG        .equ HandleEnd+4
 516 SDIB_LEN        .equ 84             ; = TIB_LEN = PAD_LEN
 517 SD_END          .equ SDIB_ORG+SDIB_LEN
 518     .ENDIF ; RAM_Size
 519 SD_LEN          .equ SD_END-SD_ORG
 520     .ENDIF ; SD_CARD_LOADER
 521 ; --------------------------;
 522 ; INFO_ORG + $40 : free use ;
 523 ; --------------------------;
 524
 525     .org    MAIN_ORG
 526 ;-------------------------------------------------------------------------------
 527 ; DTCforthMSP430FR5xxx program (FRAM) memory
 528 ;-------------------------------------------------------------------------------
 529 ; here we place the FORTH primitives without name.
 530 ; Users can access them via declarations made in \inc\MSP430FRxxxx.pat
 531 ;
 532 ;###############################################################################
 533 ; ╦┌┐┌┌┬┐┌─┐┬─┐┬─┐┬ ┬┌─┐┌┬┐┌─┐  ┌─┐┌─┐┬  ┬    ┌┬┐┌─┐┬ ┬┌┐┌  ┬ ┬┌─┐┬─┐┌─┐
 534 ; ║│││ │ ├┤ ├┬┘├┬┘│ │├─┘ │ └─┐  ├┤ ├─┤│  │     │││ │││││││  ├─┤├┤ ├┬┘├┤
 535 ; ╩┘└┘ ┴ └─┘┴└─┴└─└─┘┴   ┴ └─┘  └  ┴ ┴┴─┘┴─┘  ─┴┘└─┘└┴┘┘└┘  ┴ ┴└─┘┴└─└─┘
 536 ;###############################################################################
 537 SLEEP
 538 ; here, FAST FORTH sleeps, waiting any interrupt. With LPM4, supply current is below 1uA.
 539 ; IP,S,T,W,X,Y registers (R13 to R8) are free...
 540 ; ...and so TOS, PSP and RSP stacks within their rules of use.
 541 ;
 542 ; remember: to force SLEEP execution, you must end any interrupt routine with :
 543 ;               MOV @RSP+,SR        ; 2~
 544 ;               BIC #%1111_1000,SR  ; 2~
 545 ;               RET                 ; 3~    4 words
 546 ;
 547 ;           or faster (but return SR flags will be lost) with:
 548 ;               ADD #2 RSP          ; 1~
 549 ;               RET                 ; 3~    2 words
 550 ;
 551             CALL @PC+           ;4  SLEEP first calls BACKGND_APP
 552 PFASLEEP    .word RXON          ;   BACKGND_DEF = RXON as default BACKGND_APP; value set by WIPE.
 553             BIS &LPM_MODE,SR    ;2  enter in LPMx mode with GIE=1
 554             JMP SLEEP           ;2  instruction always executed before CPU asleeping.
 555 ;
 556 ;###############################################################################
 557
 558 ; ------------------------------------------------------------------------------
 559 ; COMPILING OPERATORS
 560 ; ------------------------------------------------------------------------------
 561 ; Primitive LIT; compiled by LITERAL
 562 ; lit      -- x    fetch inline literal to stack
 563 ; This is the run-time code of LITERAL.
 564 ;            FORTHWORD "LIT"
 565 LIT         SUB #2,PSP      ; 2  push old TOS..
 566             MOV TOS,0(PSP)  ; 3  ..onto stack
 567             MOV @IP+,TOS    ; 2  fetch new TOS value
 568             MOV @IP+,PC     ; 4  NEXT
 569
 570 ; Primitive XSQUOTE; compiled by SQUOTE
 571 ; (S")     -- addr u   run-time code to get address and length of a compiled string.
 572 XSQUOTE     SUB #4,PSP      ; 1 -- x x TOS      ; push old TOS on stack
 573             MOV TOS,2(PSP)  ; 3 -- TOS x x      ; and reserve one cell on stack
 574             MOV.B @IP+,TOS  ; 2 -- x u          ; u = lenght of string
 575             MOV IP,0(PSP)   ; 3 -- addr u       IP is odd...
 576             ADD TOS,IP      ; 1 -- addr u       IP=addr+u=addr(end_of_string)
 577             BIT #1,IP       ; 1 -- addr u       IP=addr+u   Carry set/clear if odd/even
 578             ADDC #0,IP      ; 1 -- addr u       IP=addr+u aligned
 579             MOV @IP+,PC     ; 4  16~
 580
 581 ; https://forth-standard.org/standard/core/HERE
 582 ; HERE    -- addr      returns memory ptr
 583 HERE        SUB #2,PSP
 584             MOV TOS,0(PSP)
 585             MOV &DDP,TOS
 586             MOV @IP+,PC
 587 ;-------------------------------------------------------------------------------
 588 ; BRANCH run-time
 589 ;-------------------------------------------------------------------------------
 590 ; Primitive QFBRAN; compiled by IF UNTIL
 591 ;Z ?FalseBranch   x --      ; branch if TOS is FALSE (TOS = 0)
 592 QFBRAN      CMP #0,TOS      ; 1  test TOS value
 593             MOV @PSP+,TOS   ; 2  pop new TOS value (doesn't change flags)
 594             JNZ SKIPBRANCH  ; 2  if TOS was <> 0, skip the branch; 10 cycles
 595 ; Primitive BRAN
 596 ;Z branch   --              ;
 597 BRAN        MOV @IP,IP      ; 2  take the branch destination
 598             MOV @IP+,PC     ; 4  ==> branch taken
 599
 600 ;-------------------------------------------------------------------------------
 601 ; LOOP run-time
 602 ;-------------------------------------------------------------------------------
 603 ; Primitive XDO; compiled by DO
 604 ;Z (do)    n1|u1 n2|u2 --  R: -- sys1 sys2      run-time code for DO
 605 ;                                               n1|u1=limit, n2|u2=index
 606 XDO         MOV #8000h,X    ;2 compute 8000h-limit = "fudge factor"
 607             SUB @PSP+,X     ;2
 608             MOV TOS,Y       ;1 loop ctr = index+fudge
 609             MOV @PSP+,TOS   ;2
 610             ADD X,Y         ;1 Y = INDEX
 611             PUSHM #2,X      ;4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX
 612             MOV @IP+,PC     ;4
 613
 614 ; Primitive XPLOOP; compiled by +LOOP
 615 ;Z (+loop)   n --   R: sys1 sys2 --  | sys1 sys2
 616 ;                        run-time code for +LOOP
 617 ; Add n to the loop index.  If loop terminates, clean up the
 618 ; return stack and skip the branch. Else take the inline branch.
 619 XPLOOP      ADD TOS,0(RSP)  ;4 increment INDEX by TOS value
 620             MOV @PSP+,TOS   ;2 get new TOS, doesn't change flags
 621 XLOOPNEXT   BIT #100h,SR    ;2 is overflow bit set?
 622             JZ BRAN         ;2 no overflow = loop
 623             ADD #4,RSP      ;1 empty RSP
 624 SKIPBRANCH  ADD #2,IP       ;1 overflow = loop done, skip branch ofs
 625             MOV @IP+,PC     ;4 16~ taken or not taken xloop/loop
 626
 627 ; Primitive XLOOP; compiled by LOOP
 628 ;Z (loop)   R: sys1 sys2 --  | sys1 sys2
 629 ;                        run-time code for LOOP
 630 ; Add 1 to the loop index.  If loop terminates, clean up the
 631 ; return stack and skip the branch.  Else take the inline branch.
 632 ; Note that LOOP terminates when index=8000h.
 633 XLOOP       ADD #1,0(RSP)   ;4 increment INDEX
 634             JMP XLOOPNEXT   ;2
 635
 636 ; primitive MUSMOD; compiled by ?NUMBER UM/MOD
 637 ; MUSMOD    UDVDlo UDVDhi UDIVlo -- UREMlo UQUOTlo UQUOThi
 638 ;-------------------------------------------------------------------------------
 639 ; unsigned 32-BIT DiViDend : 16-BIT DIVisor --> 32-BIT QUOTient, 16-BIT REMainder
 640 ;-------------------------------------------------------------------------------
 641
 642 ; 2 times faster if DVDhi = 0 (it's the general case)
 643
 644 ; reg     division            MU/MOD      NUM
 645 ; ---------------------------------------------
 646 ; S     = DVD(15-0)         = ud1lo     = ud1lo
 647 ; TOS   = DVD(31-16)        = ud1hi     = ud1hi
 648 ; W     = DVD(47-32)/REM    = rem       = digit --> char --> -[HP]
 649 ; T     = DIV(15-0)         = BASE      = BASE
 650 ; X     = QUOTlo            = ud2lo     = ud2lo
 651 ; Y     = QUOThi            = ud2hi     = ud2hi
 652 ; rDODOES = count
 653
 654 MUSMOD      MOV TOS,T               ;1 T = DIVlo
 655             MOV 2(PSP),S            ;3 S = DVDlo
 656             MOV @PSP,TOS            ;2 TOS = DVDhi
 657 MUSMOD1     MOV #0,W                ;1  W = REMlo = 0
 658             MOV #32,rDODOES         ;2  init loop count
 659             CMP #0,TOS              ;1  DVDhi=0 ?
 660             JNZ MDIV1               ;2  no
 661 ; -----------------------------------------
 662 MDIV1DIV2   RRA rDODOES             ;1  yes:loop count / 2
 663             MOV S,TOS               ;1      DVDhi <-- DVDlo
 664             MOV #0,S                ;1      DVDlo <-- 0
 665             MOV #0,X                ;1      QUOTlo <-- 0 (to do QUOThi = 0 at the end of division)
 666 ; -----------------------------------------
 667 MDIV1       CMP T,W                 ;1  REMlo U>= DIVlo ?
 668             JNC MDIV2               ;2  no : carry is reset
 669             SUB T,W                 ;1  yes: REMlo - DIVlo ; carry is set
 670 MDIV2       ADDC X,X                ;1  RLC quotLO
 671             ADDC Y,Y                ;1  RLC quotHI
 672             SUB #1,rDODOES          ;1  Decrement loop counter
 673             JN ENDMDIV              ;2
 674             ADD S,S                 ;1  RLA DVDlo
 675             ADDC TOS,TOS            ;1  RLC DVDhi
 676             ADDC W,W                ;1  RLC REMlo
 677             JNC MDIV1               ;2
 678             SUB T,W                 ;1  REMlo - DIVlo
 679             BIS #1,SR               ;1  SETC
 680             JMP MDIV2               ;2
 681 ENDMDIV     MOV #XDODOES,rDODOES    ;2  restore rDODOES
 682             MOV W,2(PSP)            ;3  REMlo in 2(PSP)
 683             MOV X,0(PSP)            ;3  QUOTlo in 0(PSP)
 684             MOV Y,TOS               ;1  QUOThi in TOS
 685 RET_ADR     MOV @RSP+,PC            ;4  35 words, about 473 cycles, not FORTH executable !
 686
 687 ; : SETIB SOURCE 2! 0 >IN ! ;
 688 ; SETIB      org len --        set Input Buffer, shared by INTERPRET and [ELSE]
 689 SETIB       MOV TOS,&SOURCE_LEN     ; -- org len
 690             MOV @PSP+,&SOURCE_ORG   ; -- len
 691             MOV #0,&TOIN            ;
 692             MOV @PSP+,TOS           ; --
 693             MOV @IP+,PC             ;
 694
 695 ; REFILL    accept one line to input buffer and leave org len' of the filled input buffer
 696 ; as it has no more host OS and as waiting command is done by ACCEPT, REFILL's flag is useless
 697 ; : REFILL TIB DUP TIB_LEN ACCEPT   ;   -- org len'    shared by QUIT and [ELSE]
 698 REFILL      SUB #6,PSP              ;2
 699             MOV TOS,4(PSP)          ;3
 700             MOV #TIB_LEN,TOS        ;2  -- x x len
 701             .word 40BFh             ;                   MOV #imm,index(PSP)
 702 CIB_ADR     .word TIB_ORG           ;                   imm=TIB_ORG
 703             .word 0                 ;4  -- x org len    index=0 ==> MOV #TIB_ORG,0(PSP)
 704             MOV @PSP,2(PSP)         ;4  -- org org len
 705             JMP ACCEPT              ;2  org org len -- org len'
 706
 707 XDODOES   ; -- addr                 ; 4 for CALL rDODOES       S-- BODY      PFA  R--
 708             SUB #2,PSP              ;+1
 709             MOV TOS,0(PSP)          ;+3 save TOS on parameters stack
 710             MOV @RSP+,TOS           ;+2 TOS = PFA address of master word, i.e. address of its first cell after DOES>
 711             PUSH IP                 ;+3 save IP on return stack
 712             MOV @TOS+,IP            ;+2 IP = CFA of Master word, TOS = BODY address of created word
 713             MOV @IP+,PC             ;+4 = 19~ = ITC-2
 714
 715 XDOCON                              ; 4 for CALL rDOCON       S-- CTE      PFA  R--
 716             SUB #2,PSP              ;+1
 717             MOV TOS,0(PSP)          ;+3 save TOS on parameters stack
 718             MOV @RSP+,TOS           ;+2 TOS = PFA address of master word CONSTANT
 719             MOV @TOS,TOS            ;+2 TOS = CONSTANT value
 720             MOV @IP+,PC             ;+4 = 16~ = ITC+4
 721
 722 ; https://forth-standard.org/standard/core/Rfrom
 723 ; R>    -- x    R: x --   pop from return stack
 724 RFROM
 725 XDOVAR                              ; 4 for CALL rDOVAR    ADR -- VAR
 726             SUB #2,PSP              ;+1
 727             MOV TOS,0(PSP)          ;+3
 728             MOV @RSP+,TOS           ;+2
 729             MOV @IP+,PC             ;+4 = 14~ = ITC+4
 730
 731 ;-----------------------------------;
 732 ; PUC 6.1: init Forth engine        ; common part of QABORT|WARM
 733 ;-----------------------------------;
 734 INI_FORTH                           ;
 735             CALL @PC+               ;
 736 PFA_INI_FORTH
 737     .IFNDEF SD_CARD_LOADER
 738             .word RET_ADR           ; INI_SOFT_APP default value
 739     .ELSE
 740             .word INI_SOFT_SD       ; init software SD_Card : close all handles
 741     .ENDIF
 742             MOV #INI_FORTH_INI,X    ; in FRAM INFO
 743             MOV @X+,&PFAACCEPT      ; BODYACCEPT    --> PFAACCEPT
 744             MOV @X+,&PFACR          ; BODYCR        --> PFACR
 745             MOV @X+,&PFAEMIT        ; BODYEMIT      --> PFAEMIT
 746             MOV @X+,&PFAKEY         ; BODYKEY       --> PFAKEY
 747             MOV @X+,&CIB_ADR        ; TIB_ORG       --> CIB_ADR
 748             MOV @X+,rDOCOL          ;               --> rDOCOL
 749             MOV @X+,rDODOES         ; xDODOES       --> rDODOES
 750             MOV @X+,rDOCON          ; xDOCON        --> rDOCON
 751             MOV @X+,rDOVAR          ; RFROM         --> rDOVAR
 752             MOV @X+,&CAPS           ; 32            --> CAPS            init CAPS ON
 753             MOV @X+,&BASE           ; 10            --> BASE            init decimal base
 754             MOV @RSP+,IP            ; init IP with RET_ADR = LIT|WARM from resp. QABORT|RESET
 755             MOV #SEL_P_R_D,PC       ; goto PUC 6.2 to select PWR_STATE|RST_STATE|DEEP_RESET
 756
 757     .IFDEF TERMINAL_I2C
 758         .include "forthMSP430FR_TERM_I2C.asm"
 759     .ELSE
 760         .IFDEF HALFDUPLEX
 761             .include "forthMSP430FR_TERM_HALF.asm"
 762         .ELSE
 763             .include "forthMSP430FR_TERM_UART.asm"
 764         .ENDIF
 765     .ENDIF
 766     .IFDEF SD_CARD_LOADER
 767         .include "forthMSP430FR_SD_ACCEPT.asm"
 768     .ENDIF
 769
 770     .IF DTC = 1                     ; DOCOL = CALL rDOCOL, [rDOCOL] = xdocol
 771 XDOCOL      MOV @RSP+,W             ; 2
 772             PUSH IP                 ; 3     save old IP on return stack
 773             MOV W,IP                ; 1     set new IP to PFA
 774             MOV @IP+,PC             ; 4     = NEXT
 775     .ENDIF                          ; 10 cycles
 776
 777             FORTHWORD "TYPE"
 778 ;https://forth-standard.org/standard/core/TYPE
 779 ;C TYPE    adr len --     type string to terminal
 780 TYPE        CMP #0,TOS              ;1
 781             JZ TWODROP              ;2                  abort fonction
 782             PUSH IP                 ;3
 783             MOV #TYPE_NEXT,IP       ;2
 784 TYPELOOP    MOV @PSP,Y              ;2 -- adr len       Y = adr
 785             SUB #2,PSP              ;1 -- adr x len
 786             MOV TOS,0(PSP)          ;3 -- adr len len
 787             MOV.B @Y+,TOS           ;2 -- adr len char
 788             MOV Y,2(PSP)            ;3 -- adr+1 len char
 789             MOV &PFAEMIT,PC         ;5+17               all scratch registers must be and are free
 790 TYPE_NEXT   .word $+2               ;  -- adr+1 len
 791             SUB #2,IP               ;1                  [IP] = TYPE_NEXT
 792             SUB #1,TOS              ;1 -- adr+1 len-1
 793             JNZ TYPELOOP            ;2                  37~ EMIT loop
 794             MOV @RSP+,IP            ;3 -- adr+len 0
 795 TWODROP     ADD #2,PSP              ;1 -- 0
 796 DROP        MOV @PSP+,TOS           ;2 --
 797             MOV @IP+,PC             ;4
 798
 799             FORTHWORD "CR"
 800 ; https://forth-standard.org/standard/core/CR
 801 ; CR      --               send CR to the output device
 802 CR          MOV @PC+,PC             ;3 Code Field Address (CFA) of CR
 803 PFACR       .word   BODYCR          ;  Parameter Field Address (PFA) of CR, with its default value
 804 BODYCR      mDOCOL                  ;  send CR+LF to the default output device
 805             .word   XSQUOTE
 806             .byte   2,13,10
 807             .word   TYPE,EXIT
 808
 809 ;-------------------------------------------------------------------------------
 810 ; STACK OPERATIONS
 811 ;-------------------------------------------------------------------------------
 812     .IFDEF CORE_COMPLEMENT
 813             FORTHWORD "DUP"
 814     .ENDIF
 815 ; https://forth-standard.org/standard/core/DUP
 816 ; DUP      x -- x x      duplicate top of stack
 817 DUP         SUB #2,PSP      ; 2  push old TOS..
 818             MOV TOS,0(PSP)  ; 3  ..onto stack
 819             MOV @IP+,PC     ; 4
 820
 821     .IFDEF CORE_COMPLEMENT
 822             FORTHWORD "?DUP"
 823     .ENDIF
 824 ; https://forth-standard.org/standard/core/qDUP
 825 ; ?DUP     x -- 0 | x x    DUP if nonzero
 826 QDUP        CMP #0,TOS      ; 2  test for TOS nonzero
 827             JNZ DUP         ; 2
 828             MOV @IP+,PC     ; 4
 829
 830     .IFDEF CORE_COMPLEMENT
 831             FORTHWORD "2DUP"
 832     .ENDIF
 833 ; https://forth-standard.org/standard/core/TwoDUP
 834 ; 2DUP   x1 x2 -- x1 x2 x1 x2   dup top 2 cells
 835 TWODUP      MOV TOS,-2(PSP) ; 3
 836             MOV @PSP,-4(PSP); 4
 837             SUB #4,PSP      ; 1
 838             MOV @IP+,PC     ; 4
 839
 840     .IFDEF CORE_COMPLEMENT
 841             FORTHWORD "SWAP"
 842     .ENDIF
 843 ; https://forth-standard.org/standard/core/SWAP
 844 ; SWAP     x1 x2 -- x2 x1    swap top two items
 845 SWAP        MOV @PSP,W      ; 2
 846             MOV TOS,0(PSP)  ; 3
 847             MOV W,TOS       ; 1
 848             MOV @IP+,PC     ; 4
 849
 850     .IFDEF CORE_COMPLEMENT
 851             FORTHWORD "DROP"
 852 ; https://forth-standard.org/standard/core/DROP
 853 ; DROP     x --          drop top of stack
 854             MOV @PSP+,TOS   ; 2
 855             MOV @IP+,PC     ; 4
 856
 857             FORTHWORD "NIP"
 858 ; https://forth-standard.org/standard/core/NIP
 859 ; NIP      x1 x2 -- x2         Drop the first item below the top of stack
 860             ADD #2,PSP      ; 1
 861             MOV @IP+,PC     ; 4
 862
 863         .IFNDEF OVER
 864             FORTHWORD "OVER"
 865 ;https://forth-standard.org/standard/core/OVER
 866 ;C OVER    x1 x2 -- x1 x2 x1
 867             MOV TOS,-2(PSP) ; 3 -- x1 (x2) x2
 868             MOV @PSP,TOS    ; 2 -- x1 (x2) x1
 869             SUB #2,PSP      ; 1 -- x1 x2 x1
 870             MOV @IP+,PC     ; 4
 871         .ENDIF
 872
 873             FORTHWORD "ROT"
 874 ;https://forth-standard.org/standard/core/ROT
 875 ;C ROT    x1 x2 x3 -- x2 x3 x1
 876             MOV @PSP,W      ; 2 fetch x2
 877             MOV TOS,0(PSP)  ; 3 store x3
 878             MOV 2(PSP),TOS  ; 3 fetch x1
 879             MOV W,2(PSP)    ; 3 store x2
 880             MOV @IP+,PC     ; 4
 881
 882             FORTHWORD "DEPTH"
 883     .ENDIF
 884 ; https://forth-standard.org/standard/core/DEPTH
 885 ; DEPTH    -- +n        number of items on stack, must leave 0 if stack empty
 886 DEPTH       MOV TOS,-2(PSP)
 887             MOV #PSTACK,TOS
 888             SUB PSP,TOS     ; PSP-S0--> TOS
 889             RRA TOS         ; TOS/2   --> TOS
 890             SUB #2,PSP      ; post decrement stack...
 891             MOV @IP+,PC
 892
 893     .IFDEF CORE_COMPLEMENT
 894             FORTHWORD "R@"
 895 ;https://forth-standard.org/standard/core/RFetch
 896 ;C R@    -- x     R: x -- x   fetch from rtn stk
 897             SUB #2,PSP
 898             MOV TOS,0(PSP)
 899             MOV @RSP,TOS
 900             MOV @IP+,PC
 901
 902             FORTHWORD ">R"
 903 ; https://forth-standard.org/standard/core/toR
 904 ; >R    x --   R: -- x   push to return stack
 905 TOR         PUSH TOS
 906             MOV @PSP+,TOS
 907             MOV @IP+,PC
 908
 909             FORTHWORD "R>"
 910 ; https://forth-standard.org/standard/core/Rfrom
 911 ; R>    -- x    R: x --   pop from return stack
 912             SUB #2,PSP      ; 1
 913             MOV TOS,0(PSP)  ; 3
 914             MOV @RSP+,TOS   ; 2
 915             MOV @IP+,PC     ; 4
 916
 917     .ENDIF
 918 ;-------------------------------------------------------------------------------
 919 ; ARITHMETIC OPERATIONS
 920 ;-------------------------------------------------------------------------------
 921     .IFDEF CORE_COMPLEMENT
 922             FORTHWORD "1+"
 923 ; https://forth-standard.org/standard/core/OnePlus
 924 ; 1+      n1/u1 -- n2/u2       add 1 to TOS
 925             ADD #1,TOS
 926             MOV @IP+,PC
 927
 928             FORTHWORD "1-"
 929 ; https://forth-standard.org/standard/core/OneMinus
 930 ; 1-      n1/u1 -- n2/u2     subtract 1 from TOS
 931             SUB #1,TOS
 932             MOV @IP+,PC
 933
 934             FORTHWORD "+"
 935 ;https://forth-standard.org/standard/core/Plus
 936 ;C +       n1/u1 n2/u2 -- n3/u3     add n1+n2
 937             ADD @PSP+,TOS
 938             MOV @IP+,PC
 939
 940              FORTHWORD "-"
 941     .ENDIF
 942 ; https://forth-standard.org/standard/core/Minus
 943 ; -      n1/u1 n2/u2 -- n3/u3      n3 = n1-n2
 944 MINUS       SUB @PSP+,TOS   ;2  -- n2-n1
 945 NEGATE      XOR #-1,TOS     ;1
 946 ONEPLUS     ADD #1,TOS      ;1  -- n3 = -(n2-n1) = n1-n2
 947             MOV @IP+,PC
 948
 949 ;-------------------------------------------------------------------------------
 950 ; MEMORY OPERATIONS
 951 ;-------------------------------------------------------------------------------
 952             FORTHWORD "@"
 953 ; https://forth-standard.org/standard/core/Fetch
 954 ; @       a-addr -- x   fetch cell from memory
 955 FETCH       MOV @TOS,TOS
 956             MOV @IP+,PC
 957
 958             FORTHWORD "!"
 959 ; https://forth-standard.org/standard/core/Store
 960 ; !        x a-addr --   store cell in memory
 961 STORE       MOV @PSP+,0(TOS);4
 962             MOV @PSP+,TOS   ;2
 963             MOV @IP+,PC     ;4
 964
 965 ;-------------------------------------------------------------------------------
 966 ; COMPARAISON OPERATIONS
 967 ;-------------------------------------------------------------------------------
 968     .IFDEF CORE_COMPLEMENT
 969             FORTHWORD "0="
 970     .ENDIF
 971 ; https://forth-standard.org/standard/core/ZeroEqual
 972 ; 0=     n/u -- flag    return true if TOS=0
 973 ZEROEQUAL   SUB #1,TOS      ;1 borrow (clear cy) if TOS was 0
 974             SUBC TOS,TOS    ;1 TOS=-1 if borrow was set
 975             MOV @IP+,PC     ;4
 976
 977     .IFDEF CORE_COMPLEMENT
 978             FORTHWORD "0<"
 979     .ENDIF
 980 ; https://forth-standard.org/standard/core/Zeroless
 981 ; 0<     n -- flag      true if TOS negative
 982 ZEROLESS    ADD TOS,TOS     ;1 set carry if TOS negative
 983             SUBC TOS,TOS    ;1 TOS=-1 if carry was clear
 984 INVERT      XOR #-1,TOS     ;1 TOS=-1 if carry was set
 985             MOV @IP+,PC     ;
 986
 987     .IFDEF CORE_COMPLEMENT
 988             FORTHWORD "U<"
 989     .ENDIF
 990 ; https://forth-standard.org/standard/core/Uless
 991 ; U<    u1 u2 -- flag       test u1<u2, unsigned
 992 ULESS       SUB @PSP+,TOS   ;2
 993             JZ ULESSEND     ;2 flag Z = 1
 994             MOV #-1,TOS     ;1 flag Z = 0
 995             JC ULESSEND     ;2 unsigned jump
 996             AND #0,TOS      ;1 flag Z = 1
 997 ULESSEND    MOV @IP+,PC     ;4
 998
 999     .IFDEF CORE_COMPLEMENT
1000             FORTHWORD "="
1001 ; https://forth-standard.org/standard/core/Equal
1002 ; =      x1 x2 -- flag         test x1=x2
1003 EQUAL       SUB @PSP+,TOS   ;2
1004             JZ INVERT       ;2 flag Z will be = 0
1005             AND #0,TOS      ;1 flag Z = 1
1006             MOV @IP+,PC     ;4
1007
1008             FORTHWORD "<"
1009 ;https://forth-standard.org/standard/core/less
1010 ;C <      n1 n2 -- flag        test n1<n2, signed
1011             SUB @PSP+,TOS   ;1 TOS=n2-n1
1012             JZ LESSEND      ;2 flag Z = 1
1013             JL TOSFALSE     ;2 signed jump
1014 TOSTRUE     MOV #-1,TOS     ;1 flag Z = 0
1015 LESSEND     MOV @IP+,PC     ;4
1016
1017             FORTHWORD ">"
1018 ;https://forth-standard.org/standard/core/more
1019 ;C >     n1 n2 -- flag         test n1>n2, signed
1020             SUB @PSP+,TOS   ;2 TOS=n2-n1
1021             JL TOSTRUE      ;2 --> +5
1022 TOSFALSE    AND #0,TOS      ;1 flag Z = 1
1023             MOV @IP+,PC     ;4
1024
1025 ;-------------------------------------------------------------------------------
1026 ; CORE ANS94 complement OPTION
1027 ;-------------------------------------------------------------------------------
1028     .include "ADDON/CORE_ANS.asm"
1029     .ENDIF ; CORE_COMPLEMENT
1030
1031 ;-------------------------------------------------------------------------------
1032 ; NUMERIC OUTPUT
1033 ;-------------------------------------------------------------------------------
1034 ; Numeric conversion is done last digit first, so
1035 ; the output buffer is built backwards in memory.
1036
1037             FORTHWORD "<#"
1038 ; https://forth-standard.org/standard/core/num-start
1039 ; <#    --       begin numeric conversion (initialize Hold Pointer)
1040 LESSNUM     MOV #HOLD_BASE,&HP
1041             MOV @IP+,PC
1042
1043             FORTHWORD "#"
1044 ; https://forth-standard.org/standard/core/num
1045 ; #     ud1lo ud1hi -- ud2lo ud2hi          convert 1 digit of output
1046 NUM         MOV &BASE,T             ;3                              T = Divisor
1047 NUM1        MOV @PSP,S              ;2 -- DVDlo DVDhi               S = DVDlo
1048             SUB #2,PSP              ;1 -- x x DVDhi                 TOS = DVDhi
1049             CALL #MUSMOD1           ;4 -- REMlo QUOTlo QUOThi       T is unchanged
1050             MOV @PSP+,0(PSP)        ;4 -- QUOTlo QUOThi
1051 TODIGIT     CMP.B #10,W             ;2                              W = REMlo
1052             JNC TODIGIT1            ;2  jump if U<
1053             ADD.B #7,W              ;2
1054 TODIGIT1    ADD.B #30h,W            ;2
1055 HOLDW       SUB #1,&HP              ;4  store W=char --> -[HP]
1056             MOV &HP,Y               ;3
1057             MOV.B W,0(Y)            ;3
1058             MOV @IP+,PC             ;4  23 words
1059
1060             FORTHWORD "#S"
1061 ; https://forth-standard.org/standard/core/numS
1062 ; #S    udlo udhi -- 0 0       convert remaining digits
1063 NUMS        mDOCOL
1064             .word   NUM             ;       X=QUOTlo
1065 NUM_RETURN  .word   $+2             ;       next adr
1066             SUB #2,IP               ;1      restore NUM return
1067             CMP #0,X                ;1      test ud2lo first (generally <>0)
1068             JNZ NUM1                ;2
1069             CMP #0,TOS              ;1      then test ud2hi (generally =0)
1070             JNZ NUM1                ;2
1071 EXIT        MOV @RSP+,IP
1072             MOV @IP+,PC             ;6 10 words, about 241/417 cycles/char
1073
1074             FORTHWORD "#>"
1075 ; https://forth-standard.org/standard/core/num-end
1076 ; #>    udlo:udhi -- c-addr u    end conversion, get string
1077 NUMGREATER  MOV &HP,0(PSP)
1078             MOV #HOLD_BASE,TOS
1079             SUB @PSP,TOS
1080             MOV @IP+,PC
1081
1082             FORTHWORD "HOLD"
1083 ; https://forth-standard.org/standard/core/HOLD
1084 ; HOLD  char --        add char to output string
1085 HOLD        MOV.B TOS,W             ;1
1086             MOV @PSP+,TOS           ;2
1087             JMP HOLDW               ;15
1088
1089             FORTHWORD "SIGN"
1090 ; https://forth-standard.org/standard/core/SIGN
1091 ; SIGN  n --           add minus sign if n<0
1092 SIGN        CMP #0,TOS
1093             MOV @PSP+,TOS
1094             MOV.B #'-',W
1095             JN HOLDW                ; jump if 0<
1096             MOV @IP+,PC
1097
1098             FORTHWORD "U."
1099 ; https://forth-standard.org/standard/core/Ud
1100 ; U.    u --           display u (unsigned)
1101 ; note: DDOT = UDOT + 10
1102 UDOT        MOV #0,Y                ; 1
1103 DOTTODDOT   SUB #2,PSP              ; 1 convert n|u to d|ud with Y = -1|0
1104             MOV TOS,0(PSP)          ; 3
1105             MOV Y,TOS               ; 1
1106 DDOT        PUSH IP                 ; paired with EXIT      R-- IP
1107             PUSH TOS                ; paired with RFROM     R-- IP sign
1108             AND #-1,TOS             ; clear V, set N
1109             JGE DDOTNEXT            ; if positive (N=0)
1110             XOR #-1,0(PSP)          ;4
1111             XOR #-1,TOS             ;1
1112             ADD #1,0(PSP)           ;4
1113             ADDC #0,TOS             ;1
1114 DDOTNEXT    ASMTOFORTH              ;10
1115             .word   LESSNUM,NUMS
1116             .word   RFROM,SIGN,NUMGREATER,TYPE
1117             .word   FBLANK,EMIT,EXIT
1118
1119             FORTHWORD "."
1120 ; https://forth-standard.org/standard/core/d
1121 ; .     n --           display n (signed)
1122 DOT         CMP #0,TOS
1123             JGE UDOT
1124             MOV #-1,Y
1125             JMP DOTTODDOT
1126
1127 ; ------------------------------------------------------------------------------
1128 ; STRINGS PROCESSING
1129 ; ------------------------------------------------------------------------------
1130             FORTHWORDIMM "S\34" ; immediate
1131 ; https://forth-standard.org/standard/core/Sq
1132 ; S"       --             compile in-line string
1133 SQUOTE      MOV #0,&CAPS            ; CAPS OFF
1134             mDOCOL
1135             .word   lit,XSQUOTE,COMMA
1136 SQUOTE1     .word   lit,'"'         ;      separator for WORD
1137             .word   WORDD           ; -- c-addr (= HERE)
1138             .word   $+2
1139             MOV #32,&CAPS           ; CAPS ON
1140             MOV.B @TOS,TOS          ; -- u
1141             ADD #1,TOS              ; -- u+1
1142             BIT #1,TOS              ;1 C = ~Z
1143             ADDC TOS,&DDP
1144 DROPEXIT    MOV @PSP+,TOS
1145             MOV @RSP+,IP
1146             MOV @IP+,PC
1147
1148             FORTHWORDIMM ".\34"     ; immediate
1149 ; https://forth-standard.org/standard/core/Dotq
1150 ; ."       --              compile string to print
1151 DOTQUOTE    mDOCOL
1152             .word   SQUOTE
1153             .word   lit,TYPE,COMMA,EXIT
1154
1155 ;-------------------------------------------------------------------------------
1156 ; INTERPRETER
1157 ;-------------------------------------------------------------------------------
1158             FORTHWORD "WORD"
1159 ; https://forth-standard.org/standard/core/WORD
1160 ; WORD   char -- addr        Z=1 if len=0
1161 ; parse a word delimited by char separator; by default (CAPS=$20), this word is capitalized.
1162 ; if first char is TICK, the entire word is not capitalized.
1163 WORDD       MOV #SOURCE_LEN,S       ;2 -- separator
1164             MOV @S+,X               ;2              X = src_len
1165             MOV @S+,W               ;2              W = src_org
1166             ADD W,X                 ;1              X = src_end
1167             ADD @S+,W               ;2              W = src_org + >IN = src_ptr
1168             MOV @S,Y                ;2              Y = HERE = dst_ptr
1169 SKIPCHARLOO CMP W,X                 ;1              src_ptr = src_end ?
1170             JZ SKIPCHAREND          ;2              if yes : End Of Line !
1171             CMP.B @W+,TOS           ;2              does char = separator ?
1172             JZ SKIPCHARLOO          ;2              if yes; 7~ loop
1173             SUB #1,W                ;1              move back one the (post incremented) pointer
1174 SCANWORD    MOV #96,T               ;2              T = 96 = ascii(a)-1 (test value set in a register before SCANWORD loop)
1175             MOV &CAPS,rDODOES       ;3              CAPS OFF = 0, CAPS ON = $20.
1176 QSCANTICK   CMP.B #27h,0(W)         ;4              first char = TICK ?
1177             JNZ SCANWORDLOO         ;2              no
1178             MOV #0,rDODOES          ;1              yes, don't change to upper case
1179 SCANWORDLOO MOV.B S,0(Y)            ;3              first time make room in dst for word length; next, put char @ dst.
1180             CMP W,X                 ;1              src_ptr = src_end ?
1181             JZ SCANWORDEND          ;2              if yes
1182             MOV.B @W+,S             ;2
1183             CMP.B S,TOS             ;1              does char = separator ?
1184             JZ SCANWORDEND          ;2              if yes
1185             ADD #1,Y                ;1              increment dst just before test loop
1186             CMP.B S,T               ;1              char U< 'a' ?  ('a'-1 U>= char) this condition is tested at each loop
1187             JC SCANWORDLOO          ;2              15~ upper case char loop
1188             CMP.B #123,S            ;2              char U>= 'z'+1 ?
1189             JC SCANWORDLOO          ;2              loopback if yes
1190             SUB.B rDODOES,S         ;1              convert a...z to A...Z if CAPS ON (rDODOES=$20)
1191             JMP SCANWORDLOO         ;2              22~ lower case char loop
1192 SCANWORDEND MOV #XDODOES,rDODOES    ;2
1193 SKIPCHAREND SUB &SOURCE_ORG,W       ;3 -- separator W=src_ptr - src_org = new >IN (first char separator next)
1194             MOV W,&TOIN             ;3              update >IN
1195             MOV &DDP,TOS            ;3 -- c-addr
1196             SUB TOS,Y               ;1              Y=Word_Length
1197             MOV.B Y,0(TOS)          ;3
1198             MOV @IP+,PC             ;4 -- c-addr    48 words      Z=1 <==> lenght=0 <==> EOL, Z is tested by INTERPRET
1199
1200             FORTHWORD "FIND"        ;
1201 ; https://forth-standard.org/standard/core/FIND
1202 ; FIND   c-addr -- c-addr 0   if not found ; flag Z=1       c-addr at transient RAM area (HERE)
1203 ;                  CFA -1      if found     ; flag Z=0
1204 ;                  CFA  1      if immediate ; flag Z=0
1205 ; compare WORD at c-addr (HERE)  with each of words in each of listed vocabularies in CONTEXT
1206 ; FIND to WORDLOOP  : 14/20 cycles,
1207 ; mismatch word loop: 13 cycles on len, +7 cycles on first char,
1208 ;                     +10 cycles char loop,
1209 ; VOCLOOP           : 12/18 cycles,
1210 ; WORDFOUND to end  : 21 cycles.
1211 ; note: with 16 threads vocabularies, FIND takes only! 75% of CORETEST.4th processing time
1212 FIND        SUB #2,PSP              ;1 -- ???? c-addr       reserve one cell, not at FINDEND because kill flag Z
1213             MOV TOS,S               ;1                      S=c-addr
1214             MOV.B @S,rDOCON         ;2                      rDOCON= string count
1215             MOV.B #80h,rDODOES      ;2                      rDODOES= immediate mask
1216             MOV #CONTEXT,T          ;2
1217 VOCLOOP     MOV @T+,TOS             ;2 -- ???? VOC_PFA      T=CTXT+2
1218             CMP #0,TOS              ;1                      no more vocabulary in CONTEXT ?
1219             JZ FINDEND              ;2 -- ???? 0            yes ==> exit; Z=1
1220     .SWITCH THREADS
1221     .CASE   1
1222     .ELSECASE                       ;                       search thread add 6cycles  5words
1223             MOV.B 1(S),Y            ;3 -- ???? VOC_PFA0     S=c-addr Y=first char of c-addr string
1224             AND.B #(THREADS-1)*2,Y  ;2 -- ???? VOC_PFA0     Y=thread offset
1225             ADD Y,TOS               ;1 -- ???? VOC_PFAx     TOS = words set entry
1226     .ENDCASE
1227             ADD #2,TOS              ;1 -- ???? VOC_PFA+2
1228 WORDLOOP    MOV -2(TOS),TOS         ;3 -- ???? NFA          [VOC_PFA] first, then [LFA]
1229             CMP #0,TOS              ;1 -- ???? NFA          no more word in the thread ?
1230             JZ VOCLOOP              ;2 -- ???? NFA          yes ==> search next voc in context
1231             MOV TOS,X               ;1
1232             MOV.B @X+,Y             ;2                      TOS=NFA,X=NFA+1,Y=NFA_char
1233             BIC.B rDODOES,Y         ;1                      hide Immediate bit
1234 LENCOMP     CMP.B rDOCON,Y          ;1                      compare lenght
1235             JNZ WORDLOOP            ;2 -- ???? NFA          13~ word loop on lenght mismatch
1236             MOV S,W                 ;1                      W=c-addr
1237 CHARCOMP    CMP.B @X+,1(W)          ;4                      compare chars
1238             JNZ WORDLOOP            ;2 -- ???? NFA          20~ word loop on first char mismatch
1239             ADD #1,W                ;1
1240             SUB.B #1,Y              ;1                      decr count
1241             JNZ CHARCOMP            ;2 -- ???? NFA          10~ char loop
1242
1243 WORDFOUND   BIT #1,X                ;1
1244             ADDC #0,X               ;1
1245             MOV X,S                 ;1                      S=aligned CFA
1246             CMP.B #0,0(TOS)         ;3 -- ???? NFA          0(TOS)=NFA_first_char
1247             MOV #1,TOS              ;1 -- ???? 1            preset immediate flag
1248             JN FINDEND              ;2 -- ???? 1            jump if negative: NFA have immediate bit set
1249             SUB #2,TOS              ;1 -- ???? -1
1250 FINDEND     MOV S,0(PSP)            ;3 not found: -- c-addr 0                           flag Z=1
1251             MOV #xdocon,rDOCON      ;2     found: -- xt -1|+1 (not immediate|immediate) flag Z=0
1252             MOV #xdodoes,rDODOES    ;2
1253             MOV @IP+,PC             ;4 42/47 words
1254
1255     .IFDEF MPY_32 ; if 32 bits hardware multiplier
1256
1257             FORTHWORD ">NUMBER"
1258 ; >NUMBER  ud1lo ud1hi addr1 cnt1 -- ud2lo ud2hi addr2 cnt2
1259 ; https://forth-standard.org/standard/core/toNUMBER
1260 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
1261 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
1262 ; Conversion continues left-to-right until a character that is not convertible (including '.'  ','  '_')
1263 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
1264 ; or the first character past the end of the string if the string was entirely converted.
1265 ; u2 is the number of unconverted characters in the string.
1266 ; An ambiguous condition exists if ud2 overflows during the conversion.
1267 TONUMBER    MOV @PSP+,S             ;2 -- ud1lo ud1hi cnt1  S = addr1
1268             MOV @PSP+,Y             ;2 -- ud1lo cnt1        Y = ud1hi
1269             MOV @PSP,X              ;2 -- x cnt1            X = ud1lo
1270             SUB #4,PSP              ;1 -- x x x cnt
1271             MOV &BASE,T             ;3
1272 TONUMLOOP   MOV.B @S,W              ;2 -- x x x cnt         S=adr, T=base, W=char, X=udlo, Y=udhi
1273 DDIGITQ     SUB.B #30h,W            ;2                      skip all chars < '0'
1274             CMP.B #10,W             ;2                      char was U< 58 (U< ':') ?
1275             JNC DDIGITQNEXT         ;2                      no
1276             SUB.B #7,W              ;2
1277             CMP.B #10,W             ;2
1278             JNC TONUMEND            ;2 -- x x x cnt         if '9' < char < 'A', then return to QNUMBER with Z=0
1279 DDIGITQNEXT CMP T,W                 ;1                      digit-base
1280             BIC #Z,SR               ;1                      reset Z before return to QNUMBER because
1281             JC  TONUMEND            ;2                          with Z=1, QNUMBER conversion would be true :-(
1282 UDSTAR      MOV X,&MPY32L           ;3                      Load 1st operand (ud1lo)
1283             MOV Y,&MPY32H           ;3                      Load 1st operand (ud1hi)
1284             MOV T,&OP2              ;3                      Load 2nd operand with BASE
1285             MOV &RES0,X             ;3                      lo result in X (ud2lo)
1286             MOV &RES1,Y             ;3                      hi result in Y (ud2hi)
1287 MPLUS       ADD W,X                 ;1                      ud2lo + digit
1288             ADDC #0,Y               ;1                      ud2hi + carry
1289 TONUMPLUS   ADD #1,S                ;1                      adr+1
1290             SUB #1,TOS              ;1 -- x x x cnt         cnt-1
1291             JNZ TONUMLOOP           ;2                      if count <>0
1292 TONUMEND    MOV S,0(PSP)            ;3 -- x x addr2 cnt2
1293             MOV Y,2(PSP)            ;3 -- x ud2hi addr2 cnt2
1294             MOV X,4(PSP)            ;3 -- ud2lo ud2hi addr2 cnt2
1295             MOV @IP+,PC             ;4 42 words
1296
1297 ; ?NUMBER makes the interface between INTERPRET and >NUMBER; it's a subset of INTERPRET.
1298 ; convert a string to a signed number; FORTH 2012 prefixes $  %  # are recognized,
1299 ; FORTH 2012 'char' numbers also, digits separator '_' also.
1300 ; with DOUBLE_INPUT switched ON, 32 bits signed numbers (with decimal point) are recognized,
1301 ; with FIXPOINT_INPUT switched ON, Q15.16 signed numbers (with comma) are recognized.
1302 ; prefixes ' # % $ - are processed before calling >NUMBER
1303 ; chars . , _  are processed as >NUMBER exits.
1304 ;Z ?NUMBER  addr -- n|d -1  if convert ok ; flag Z=0, UF9=1 if double
1305 ;Z          addr -- addr 0  if convert ko ; flag Z=1
1306 QNUMBER
1307         .IFDEF DOUBLE_NUMBERS       ;                           DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1308             BIC #UF9,SR             ;2                          reset UF9 used as double number flag
1309         .ENDIF                      ;
1310             MOV &BASE,T             ;3                          T=BASE
1311             MOV #0,S                ;1                          S=sign of result
1312             PUSHM #3,IP             ;5 R-- IP sign base         PUSH IP,S,T
1313             MOV #TONUMEXIT,IP       ;2                          set TONUMEXIT as return from >NUMBER
1314             MOV #0,X                ;1                          X=ud1lo
1315             MOV #0,Y                ;1                          Y=ud1hi
1316             SUB #8,PSP              ;1 -- x x x x addr          make room for TOS and >NUMBER
1317             MOV TOS,6(PSP)          ;3 -- addr x x x addr
1318             MOV TOS,S               ;1                          S=addr
1319             MOV.B @S+,TOS           ;2 -- addr x x x cnt        TOS=count
1320 QTICK       CMP.B #027h,0(S)        ;4                          prefix = ' ?
1321             JNZ QNUMLDCHAR          ;2                          no
1322             MOV.B 1(S),S            ;3
1323             MOV S,4(PSP)            ;3 -- addr ud2lo x x cnt    ud2lo = ASCII code of 'char'
1324             CMP.B #3,TOS            ;2                          string must be 3 chars long
1325             JMP QNUMNEXT            ;2
1326 QNUMLDCHAR  MOV.B @S,W              ;2                          W=char
1327 QMINUS      SUB.B #'-',W            ;2                          sign minus ?
1328             JNC QBINARY             ;2                          jump if char < '-'
1329             JNZ TONUMLOOP           ;2 -- addr x x x cnt        jump if char > '-'
1330             MOV #-1,2(RSP)          ;3 R-- IP sign base         set sign flag
1331             JMP PREFIXED            ;2
1332 QBINARY     MOV #2,T                ;1                          preset base 2
1333             ADD.B #8,W              ;1                          binary '%' prefix ?
1334             JZ PREFIXED             ;2                          yes
1335 QDECIMAL    ADD #8,T                ;1                          preset base 10
1336             ADD.B #2,W              ;1                          decimal '#' prefix ?
1337             JZ PREFIXED             ;2                          yes
1338 QHEXA       MOV #16,T               ;2                          preset base 16
1339             ADD.B #-1,W             ;1                          hex '$' prefix ?
1340             JNZ QNUMNEXT            ;2 -- addr x x x cnt        abort if not recognized prefix
1341 PREFIXED    ADD #1,S                ;1
1342             SUB #1,TOS              ;1 -- addr x x x cnt-1      S=adr+1 TOS=count-1
1343             JMP QNUMLDCHAR          ;2
1344 ; ----------------------------------;
1345
1346 TONUMEXIT   .word $+2               ;  -- addr ud2lo-hi addr2 cnt2      R-- IP sign BASE    S=addr2
1347 ; ----------------------------------;
1348             JZ QNUMNEXT             ;2                                  TOS=cnt2, Z=1 if conversion is ok
1349 ; ----------------------------------;
1350             SUB #2,IP               ;                                   redefines TONUMEXIT as >NUMBER return, if loopback applicable
1351             CMP.B #28h,W            ;                                   rejected char by >NUMBER is a underscore ? ('_'-30h-7 = 28h)
1352             JZ TONUMPLUS            ;                                   yes: loopback to >NUMBER to skip char
1353 ; ----------------------------------;
1354         .IFDEF DOUBLE_NUMBERS       ;                                   DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1355             BIT #UF9,SR             ;                                   UF9 already set ? ( when you have typed .. )
1356             JNZ QNUMNEXT            ;                                   yes, goto QNUMKO
1357             BIS #UF9,SR             ;2                                  set double number flag
1358         .ENDIF
1359 ; ----------------------------------;
1360         .IFDEF DOUBLE_INPUT         ;
1361             CMP.B #0F7h,W           ;2                                  rejected char by >NUMBER is a decimal point ? ('.'-37h = -9)
1362             JZ TONUMPLUS            ;2                                  yes, loopback to >NUMBER to skip char
1363         .ENDIF                      ;
1364 ; ----------------------------------;
1365         .IFDEF FIXPOINT_INPUT       ;
1366             CMP.B #0F5h,W           ;2                                  rejected char by >NUMBER is a comma ? (','-37h = -0Bh)
1367             JNZ QNUMNEXT            ;2                                  no: with Z=0 ==> goto QNUMKO
1368 ; ----------------------------------;
1369 S15Q16      MOV TOS,W               ;1 -- addr ud2lo x x x              W=cnt2
1370             MOV #0,X                ;1 -- addr ud2lo x 0 x              init X = ud2lo' = 0
1371 S15Q16LOOP  MOV X,2(PSP)            ;3 -- addr ud2lo ud2lo' ud2lo' x    0(PSP) = ud2lo'
1372             SUB.B #1,W              ;1                                  decrement cnt2
1373             MOV W,X                 ;1                                  X = cnt2-1
1374             ADD S,X                 ;1                                  X = end_of_string-1,-2,-3...
1375             MOV.B @X,X              ;2                                  X = last char of string first (reverse conversion)
1376             SUB.B #30h,X            ;2                                  char --> digit conversion
1377             CMP.B #10,X             ;2
1378             JNC QS15Q16DIGI         ;2                                  if 0 <= digit < 10
1379             SUB.B #7,X              ;2                                  char
1380             CMP.B #10,X             ;2                                  to skip all chars between "9" and "A"
1381             JNC S15Q16EOC           ;2
1382 QS15Q16DIGI CMP T,X                 ;1                                  R-- IP sign BASE    is X a digit ?
1383             JC S15Q16EOC            ;2 -- addr ud2lo ud2lo' x ud2lo'    if X>=base
1384             MOV X,0(PSP)            ;3 -- addr ud2lo ud2lo' digit x
1385             MOV T,TOS               ;1 -- addr ud2lo ud2lo' digit base  R-- IP sign base
1386             PUSHM #3,S              ;5                                  PUSH S,T,W: R-- IP sign base addr2 base cnt2
1387             CALL #MUSMOD            ;4 -- addr ud2lo ur uqlo uqhi       CALL MU/MOD
1388             POPM #3,S               ;5                                  restore W,T,S: R-- IP sign BASE
1389             JMP S15Q16LOOP          ;2                                  W=cnt
1390 S15Q16EOC   MOV 4(PSP),2(PSP)       ;5 -- addr ud2lo ud2hi uqlo x       ud2lo from >NUMBER becomes here ud2hi part of Q15.16
1391             MOV @PSP,4(PSP)         ;4 -- addr ud2lo ud2hi x x          uqlo becomes ud2lo part of Q15.16
1392             CMP.B #0,W              ;1                                  count = 0 if end of conversion ok
1393         .ENDIF ; FIXPOINT_INPUT     ;
1394 ; ----------------------------------;
1395 QNUMNEXT    POPM #3,IP              ;5 -- addr ud2lo-hi x x             POPM T,S,IP  S = sign flag = {-1;0}
1396             MOV S,TOS               ;1 -- addr ud2lo-hi x sign
1397             MOV T,&BASE             ;3
1398             JZ QNUMOK               ;2 -- addr ud2lo-hi x sign          conversion OK if Z=1
1399 QNUMKO
1400         .IFDEF DOUBLE_NUMBERS       ;
1401             BIC #UF9,SR             ;2                                  reset flag UF9, before next use as double number flag
1402         .ENDIF
1403             ADD #6,PSP              ;1 -- addr sign
1404             AND #0,TOS              ;1 -- addr ff                       TOS=0 and Z=1 ==> conversion ko
1405             MOV @IP+,PC             ;4
1406 ; ----------------------------------;
1407         .IFDEF DOUBLE_NUMBERS       ;  -- addr ud2lo-hi x sign
1408 QNUMOK      ADD #2,PSP              ;1 -- addr ud2lo-hi sign
1409             MOV 2(PSP),4(PSP)       ;5 -- udlo udlo udhi sign
1410             MOV @PSP+,0(PSP)        ;4 -- udlo udhi sign                note : PSP is incremented before write back.
1411             XOR #-1,TOS             ;1 -- udlo udhi inv(sign)
1412             JNZ QDOUBLE             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
1413             XOR #-1,TOS             ;1 -- udlo udhi tf
1414 QDNEGATE    XOR #-1,2(PSP)          ;3
1415             XOR #-1,0(PSP)          ;3 -- (dlo dhi)-1 tf
1416             ADD #1,2(PSP)           ;3
1417             ADDC #0,0(PSP)          ;3
1418 QDOUBLE     BIT #UF9,SR             ;2 -- dlo dhi tf                    decimal point or comma fixpoint ?
1419             JNZ QNUMEND             ;2                                  leave double
1420             ADD #2,PSP              ;1 -- n tf                          leave number
1421 QNUMEND     MOV @IP+,PC             ;4                                  TOS<>0 and Z=0 ==> conversion ok
1422         .ELSE
1423 QNUMOK      ADD #4,PSP              ;1 -- addr ud2lo sign
1424             MOV @PSP+,0(PSP)        ;4 -- udlo sign                     note : PSP is incremented before write back !!!
1425             XOR #-1,TOS             ;1 -- udlo inv(sign)
1426             JNZ QNUMEND             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
1427             XOR #-1,TOS             ;1 -- udlo tf                       TOS=-1 and Z=0
1428 QNEGATE     XOR #-1,0(PSP)          ;3
1429             ADD #1,0(PSP)           ;3 -- n tf
1430 QNUMEND     MOV @IP+,PC             ;4                                  TOS=-1 and Z=0 ==> conversion ok
1431         .ENDIF ; DOUBLE_NUMBERS     ;
1432
1433     .ELSE ; no hardware MPY
1434
1435             FORTHWORD "UM*"
1436 ; T.I. UNSIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud
1437 ; https://forth-standard.org/standard/core/UMTimes
1438 ; UM*     u1 u2 -- ud   unsigned 16x16->32 mult.
1439 UMSTAR      MOV @PSP,S              ;2 MDlo
1440 UMSTAR1     MOV #0,T                ;1 MDhi=0
1441             MOV #0,X                ;1 RES0=0
1442             MOV #0,Y                ;1 RES1=0
1443             MOV #1,W                ;1 BIT TEST REGISTER
1444 UMSTARLOOP  BIT W,TOS               ;1 TEST ACTUAL BIT MRlo
1445             JZ UMSTARNEXT           ;2 IF 0: DO NOTHING
1446             ADD S,X                 ;1 IF 1: ADD MDlo TO RES0
1447             ADDC T,Y                ;1      ADDC MDhi TO RES1
1448 UMSTARNEXT  ADD S,S                 ;1 (RLA LSBs) MDlo x 2
1449             ADDC T,T                ;1 (RLC MSBs) MDhi x 2
1450             ADD W,W                 ;1 (RLA) NEXT BIT TO TEST
1451             JNC UMSTARLOOP          ;2 IF BIT IN CARRY: FINISHED    10~ loop
1452             MOV X,0(PSP)            ;3 low result on stack
1453             MOV Y,TOS               ;1 high result in TOS
1454             MOV @IP+,PC             ;4 17 words
1455
1456             FORTHWORD ">NUMBER"
1457 ; https://forth-standard.org/standard/core/toNUMBER
1458 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
1459 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
1460 ; Conversion continues left-to-right until a character that is not convertible, including '.', ',' or '_',
1461 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
1462 ; or the first character past the end of the string if the string was entirely converted.
1463 ; u2 is the number of unconverted characters in the string.
1464 ; An ambiguous condition exists if ud2 overflows during the conversion.
1465 ; >NUMBER  ud1lo|ud1hi addr1 count1 -- ud2lo|ud2hi addr2 count2
1466 TONUMBER    MOV @PSP,S              ;2                          S=adr
1467             MOV TOS,T               ;1                          T=count
1468             MOV &BASE,W             ;3
1469 TONUMLOOP   MOV.B @S,Y              ;2 -- ud1lo ud1hi x x       S=adr, T=count, W=BASE, Y=char
1470 DDIGITQ     SUB.B #30h,Y            ;2                          skip all chars < '0'
1471             CMP.B #10,Y             ;2                          char was > "9" ?
1472             JNC DDIGITQNEXT         ;2 -- ud1lo ud1hi x x       no: good end
1473             SUB.B #07,Y             ;2                          skip all chars between "9" and "A"
1474             CMP.B #10,Y             ;2                          char was < "A" ?
1475             JNC TONUMEND            ;2                          yes: for bad end
1476 DDIGITQNEXT CMP W,Y                 ;1 -- ud1lo ud1hi x x       digit-base
1477             BIC #Z,SR               ;1                          reset Z before jmp TONUMEND because...
1478             JC  TONUMEND            ;2                          ...QNUMBER conversion will be true if Z = 1  :-(
1479 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
1480             MOV 2(PSP),S            ;3 -- ud1lo ud1hi x x       S=ud1hi
1481             MOV W,TOS               ;1 -- ud1lo ud1hi x base
1482             MOV #UMSTARNEXT1,IP     ;2
1483 UMSTARONE   JMP UMSTAR1             ;2                          ud1hi * base -- x ud3hi             X=ud3lo
1484 UMSTARNEXT1 .word   $+2             ;  -- ud1lo ud1hi x ud3hi
1485             MOV X,2(RSP)            ;3                                                          r-- IP adr count base ud3lo digit
1486             MOV 4(PSP),S            ;3 -- ud1lo ud1hi x ud3hi   S=ud1lo
1487             MOV 4(RSP),TOS          ;3 -- ud1lo ud1hi x base
1488             MOV #UMSTARNEXT2,IP     ;2
1489 UMSTARTWO   JMP UMSTAR1             ;2 -- ud1lo ud1hi x ud4hi   X=ud4lo
1490 UMSTARNEXT2 .word   $+2             ;  -- ud1lo ud1hi x ud4hi
1491 MPLUS       ADD @RSP+,X             ;2 -- ud1lo ud1hi x ud4hi   X=ud4lo+digit=ud2lo             r-- IP adr count base ud3lo
1492             ADDC @RSP+,TOS          ;2 -- ud1lo ud1hi x ud2hi   TOS=ud4hi+ud3lo+carry=ud2hi     r-- IP adr count base
1493             MOV X,4(PSP)            ;3 -- ud2lo ud1hi x ud2hi
1494             MOV TOS,2(PSP)          ;3 -- ud2lo ud2hi x x                                       r-- IP adr count base
1495             POPM #4,IP              ;6 -- ud2lo ud2hi x x       W=base, T=count, S=adr, IP=prevIP   r--
1496 TONUMPLUS   ADD #1,S                ;1
1497             SUB #1,T                ;1
1498             JNZ TONUMLOOP           ;2 -- ud2lo ud2hi x x       S=adr+1, T=count-1, W=base     68 cycles char loop
1499 TONUMEND    MOV S,0(PSP)            ;3 -- ud2lo ud2hi adr2 count2
1500             MOV T,TOS               ;1 -- ud2lo ud2hi adr2 count2
1501             MOV @IP+,PC             ;4 50/82 words/cycles, W = BASE
1502
1503 ; ?NUMBER makes the interface between >NUMBER and INTERPRET; it's a subset of INTERPRET.
1504 ; convert a string to a signed number; FORTH 2012 prefixes ' $, %, # are recognized
1505 ; digits separator '_' also.
1506 ; with DOUBLE_INPUT switched ON, 32 bits signed numbers (with decimal point) are recognized
1507 ; with FIXPOINT_INPUT switched ON, Q15.16 signed numbers (with comma) are recognized.
1508 ; prefixes ' # % $ - are processed before calling >NUMBER
1509 ; chars . , _ are processed as >NUMBER exits
1510 ;Z ?NUMBER  addr -- n|d -1  if convert ok ; flag Z=0, UF9=1 if double
1511 ;Z          addr -- addr 0  if convert ko ; flag Z=1
1512 QNUMBER
1513         .IFDEF DOUBLE_NUMBERS       ;           DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1514             BIC #UF9,SR             ;2          reset flag UF9, before use as double number flag
1515         .ENDIF                      ;
1516             MOV &BASE,T             ;3          T=BASE
1517             MOV #0,S                ;1
1518             PUSHM #3,IP             ;5          R-- IP sign base (push IP,S,T)
1519             MOV #TONUMEXIT,IP       ;2                      define >NUMBER return
1520             MOV T,W                 ;1          W=BASE
1521             SUB #8,PSP              ;1 -- x x x x addr
1522             MOV TOS,6(PSP)          ;3 -- addr x x x addr
1523             MOV #0,4(PSP)           ;3
1524             MOV #0,2(PSP)           ;3 -- addr 0 0 x addr
1525             MOV TOS,S               ;1 -- addr ud=0 x x
1526             MOV.B @S+,T             ;2                      S=addr, T=count
1527 QTICK       CMP.B #27h,0(S)         ;4                      prefix = ' ?
1528             JNZ QNUMLDCHAR          ;2                      no
1529             MOV.B 1(S),4(PSP)       ;5 -- addr ud2lo 0 x x  ud2lo = ASCII code of 'char'
1530             CMP.B #3,TOS            ;2                      string must be 3 chars long
1531             JMP QNUMNEXT            ;2
1532 QNUMLDCHAR  MOV.B @S,Y              ;2                      Y=char
1533 QMINUS      SUB.B #'-',Y            ;2 -- addr ud=0 x x     sign minus ?
1534             JNC QBINARY             ;2                      if char U< '-'
1535             JNZ TONUMLOOP           ;2                      if char U> '-'
1536             MOV #-1,2(RSP)          ;3                      R-- IP sign base
1537             JMP PREFIXED            ;2
1538 QBINARY     MOV #2,W                ;1                      preset base 2
1539             ADD.B #8,Y              ;1                      binary prefix ?
1540             JZ PREFIXED             ;2                      yes
1541 QDECIMAL    ADD #8,W                ;1                      preset base 10
1542             ADD.B #2,Y              ;1                      decimal prefix ?
1543             JZ PREFIXED             ;2                      yes
1544 QHEXA       MOV #16,W               ;1                      preset base 16
1545             ADD.B #-1,Y             ;2                      hex prefix ?
1546             JNZ QNUMNEXT            ;2 -- addr x x x cnt    abort if not recognized prefix
1547 PREFIXED    ADD #1,S                ;1
1548             SUB #1,T                ;1                      S=adr+1 T=count-1
1549             JMP QNUMLDCHAR          ;2
1550 ; ----------------------------------;42
1551
1552 TONUMEXIT   .word   $+2             ;  -- addr ud2lo-hi addr2 cnt2      R-- IP sign BASE    S=addr2,T=cnt2
1553 ; ----------------------------------;
1554             JZ QNUMNEXT             ;2                                  if conversion is ok
1555 ; ----------------------------------;
1556             SUB #2,IP
1557             CMP.B #28h,Y            ;                                   rejected char by >NUMBER is a underscore ?
1558             JZ TONUMPLUS            ;                                   yes: loopback to >NUMBER to skip char
1559         .IFDEF DOUBLE_NUMBERS       ;                                   DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1560             BIT #UF9,SR             ;                                   UF9 already set ? (you have wrongly typed two points)
1561             JNZ QNUMNEXT            ;                                   yes, goto QNUMKO
1562             BIS #UF9,SR             ;2                                  set double number flag
1563         .ENDIF
1564         .IFDEF DOUBLE_INPUT
1565             CMP.B #0F7h,Y           ;2                                  rejected char by >NUMBER is a decimal point ?
1566             JZ TONUMPLUS            ;2                                  to terminate conversion
1567         .ENDIF
1568         .IFDEF FIXPOINT_INPUT       ;
1569             CMP.B #0F5h,Y           ;2                                  rejected char by >NUMBER is a comma ?
1570             JNZ QNUMNEXT            ;2                                  no, goto QNUMKO
1571 ; ----------------------------------;
1572 S15Q16      MOV #0,X                ;1 -- addr ud2lo x 0 x              init ud2lo' = 0
1573 S15Q16LOOP  MOV X,2(PSP)            ;3 -- addr ud2lo ud2lo' ud2lo' x    X = 0(PSP) = ud2lo'
1574             SUB.B #1,T              ;1                                  decrement cnt2
1575             MOV T,X                 ;1                                  X = cnt2-1
1576             ADD S,X                 ;1                                  X = end_of_string-1, first...
1577             MOV.B @X,X              ;2                                  X = last char of string, first...
1578             SUB.B #30h,X            ;2                                  char --> digit conversion
1579             CMP.B #10,X             ;2
1580             JNC QS15Q16DIGI         ;2
1581             SUB.B #7,X              ;2
1582             CMP.B #10,X             ;2
1583             JNC S15Q16EOC           ;2
1584 QS15Q16DIGI CMP W,X                 ;1                                  R-- IP sign BASE, W=BASE,    is X a digit ?
1585             JC  S15Q16EOC           ;2 -- addr ud2lo ud2lo' x ud2lo'    if no
1586             MOV X,0(PSP)            ;3 -- addr ud2lo ud2lo' digit x
1587             MOV W,TOS               ;1 -- addr ud2lo ud2lo' digit base  R-- IP sign base
1588             PUSHM #3,S              ;5                                  PUSH S,T,W: R-- IP sign base addr2 cnt2 base
1589             CALL #MUSMOD            ;4 -- addr ud2lo ur uqlo uqhi
1590             POPM #3,S               ;5                                  restore W,T,S: R-- IP sign BASE
1591             JMP S15Q16LOOP          ;2                                  W=cnt
1592 S15Q16EOC   MOV 4(PSP),2(PSP)       ;5 -- addr ud2lo ud2lo uqlo x       ud2lo from >NUMBER part1 becomes here ud2hi=S15 part2
1593             MOV @PSP,4(PSP)         ;4 -- addr ud2lo ud2hi x x          uqlo becomes ud2lo
1594             CMP.B #0,T              ;1                                  cnt2 = 0 if end of conversion ok
1595         .ENDIF ; FIXPOINT_INPUT     ;
1596 ; ----------------------------------;97
1597 QNUMNEXT    POPM #3,IP              ;4 -- addr ud2lo-hi x cnt2          POPM T,S,IP   S = sign flag = {-1;0}
1598             MOV S,TOS               ;1 -- addr ud2lo-hi x sign
1599             MOV T,&BASE             ;3
1600             JZ QNUMOK               ;2 -- addr ud2lo-hi x sign          flag Z=1: conversion OK
1601 QNUMKO                              ;                                   flag Z=0
1602         .IFDEF DOUBLE_NUMBERS
1603             BIC #UF9,SR
1604         .ENDIF
1605             ADD #6,PSP              ;1 -- addr sign
1606             AND #0,TOS              ;1 -- addr ff                       TOS=0 and Z=1 ==> conversion ko
1607             MOV @IP+,PC             ;4
1608 ; ----------------------------------;
1609         .IFDEF DOUBLE_NUMBERS
1610 QNUMOK      ADD #2,PSP              ;1 -- addr ud2lo ud2hi sign
1611             MOV 2(PSP),4(PSP)       ;  -- udlo udlo udhi sign
1612             MOV @PSP+,0(PSP)        ;4 -- udlo udhi sign                note : PSP is incremented before write back !!!
1613             XOR #-1,TOS             ;1 -- udlo udhi inv(sign)
1614             JNZ QDOUBLE             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
1615             XOR #-1,TOS             ;1 -- udlo udhi tf
1616 Q2NEGATE    XOR #-1,2(PSP)          ;3
1617             XOR #-1,0(PSP)          ;3
1618             ADD #1,2(PSP)           ;3
1619             ADDC #0,0(PSP)          ;3 -- dlo dhi tf
1620 QDOUBLE     BIT #UF9,SR             ;2 -- dlo dhi tf                decimal point added ?
1621             JNZ QNUMEND             ;2 -- dlo dhi tf                leave double
1622             ADD #2,PSP              ;1 -- dlo tf                    leave number, Z=0
1623 QNUMEND     MOV @IP+,PC             ;4                              TOS=-1 and Z=0 ==> conversion ok
1624         .ELSE
1625 QNUMOK      ADD #4,PSP              ;1 -- addr ud2lo sign
1626             MOV @PSP+,0(PSP)        ;4 -- udlo sign                 note : PSP is incremented before write back !!!
1627             XOR #-1,TOS             ;1 -- udlo inv(sign)
1628             JNZ QNUMEND             ;2                              if jump : TOS=-1 and Z=0 ==> conversion ok
1629             XOR #-1,TOS             ;1 -- udlo tf                   TOS=-1 and Z=0
1630 QNEGATE     XOR #-1,0(PSP)          ;3
1631             ADD #1,0(PSP)           ;3 -- n tf
1632 QNUMEND     MOV @IP+,PC             ;4                              TOS=-1 and Z=0 ==> conversion ok
1633         .ENDIF ; DOUBLE_NUMBERS
1634
1635     .ENDIF ; of Hardware/Software MPY
1636
1637 ;-------------------------------------------------------------------------------
1638 ; DICTIONARY MANAGEMENT
1639 ;-------------------------------------------------------------------------------
1640             FORTHWORD ","
1641 ; https://forth-standard.org/standard/core/Comma
1642 ; ,    x --           append cell to dict
1643 COMMA       MOV &DDP,W              ;3
1644             MOV TOS,0(W)            ;3
1645             ADD #2,&DDP             ;3
1646             MOV @PSP+,TOS           ;2
1647             MOV @IP+,PC             ;4 15~
1648
1649         .IFDEF CORE_COMPLEMENT
1650             FORTHWORD "EXECUTE"
1651 ; https://forth-standard.org/standard/core/EXECUTE
1652 ; EXECUTE   i*x xt -- j*x   execute Forth word at 'xt'
1653             JMP EXECUTE
1654         .ENDIF
1655
1656             FORTHWORDIMM "LITERAL"  ; immediate
1657 ; https://forth-standard.org/standard/core/LITERAL
1658 ; LITERAL  n --        append single numeric literal if compiling state
1659 ;          d --        append two numeric literals if compiling state and UF9<>0 (not ANS)
1660     .IFDEF DOUBLE_NUMBERS           ; are recognized
1661 LITERAL     CMP #0,&STATE           ;3
1662             JZ LITERAL2             ;2 if interpreting state, clear UF9 flag then NEXT
1663             MOV TOS,X               ;1
1664 LITERAL1    MOV &DDP,W              ;3 X = n|HId
1665             ADD #4,&DDP             ;3
1666             MOV #LIT,0(W)           ;4
1667             MOV X,2(W)              ;3
1668             MOV @PSP+,TOS           ;2
1669             BIT #UF9,SR             ;2 double number ?
1670 LITERAL2    BIC #UF9,SR             ;2    in all case, clear UF9
1671             JZ LITERALEND           ;2 no
1672             MOV TOS,2(W)            ;3
1673             JMP LITERAL1            ;2
1674 LITERALEND  MOV @IP+,PC             ;4
1675     .ELSE
1676 LITERAL     CMP #0,&STATE           ;3
1677             JZ LITERALEND           ;2 if interpreting state, do nothing
1678 LITERAL1    MOV &DDP,W              ;3
1679             ADD #4,&DDP             ;3
1680             MOV #LIT,0(W)           ;4
1681             MOV TOS,2(W)            ;3
1682             MOV @PSP+,TOS           ;2
1683 LITERALEND  MOV @IP+,PC             ;4
1684     .ENDIF
1685
1686             FORTHWORD "COUNT"
1687 ; https://forth-standard.org/standard/core/COUNT
1688 ; COUNT   c-addr1 -- adr len   counted->adr/len
1689 COUNT       SUB #2,PSP              ;1
1690             ADD #1,TOS              ;1
1691             MOV TOS,0(PSP)          ;3
1692             MOV.B -1(TOS),TOS       ;3
1693             MOV @IP+,PC             ;4 15~
1694
1695             FORTHWORD "INTERPRET"
1696 ; INTERPRET    i*x addr u -- j*x      interpret given buffer
1697 ; This is the common factor of EVALUATE and QUIT.
1698 ; set addr u as input buffer then parse it word by word
1699 INTERPRET   mDOCOL                  ;
1700             .word   SETIB           ;
1701 INTLOOP     .word   FBLANK,WORDD    ; -- c-addr     Z = 1 --> End Of Line
1702             .word   $+2             ;
1703             JZ DROPEXIT             ;2              Z = 1 --> EOL reached
1704             MOV #INTFINDNEXT,IP     ;2              define INTFINDNEXT as FIND return
1705             JMP FIND                ;2
1706 INTFINDNEXT .word   $+2             ; -- c-addr fl  Z = 1 -->not found
1707             MOV TOS,W               ;               W = flag =(-1|0|+1)  as (normal|not_found|immediate)
1708             MOV @PSP+,TOS           ; -- c-addr
1709             MOV #INTQNUMNEXT,IP     ;2              define QNUMBER return
1710             JZ QNUMBER              ;2              Z = 1 --> not found, search a number
1711             MOV #INTLOOP,IP         ;2              define (EXECUTE | COMMA) return
1712             XOR &STATE,W            ;3
1713             JZ COMMA                ;2              if W xor STATE = 0 compile xt then loop back to INTLOOP
1714 EXECUTE     PUSH TOS                ;3
1715             MOV @PSP+,TOS           ;2 --
1716             MOV @RSP+,PC            ;4              xt --> PC
1717
1718 INTQNUMNEXT .word   $+2             ;  -- n|c-addr fl   Z = 1 --> not a number, SR(UF9) double number request
1719             MOV @PSP+,TOS           ;2
1720             MOV #INTLOOP,IP         ;2 -- n|c-addr  define LITERAL return
1721             JNZ LITERAL             ;2 n --         Z = 0 --> is a number, execute LITERAL then loop back to INTLOOP
1722
1723 NotFoundexe ADD.B #1,0(TOS)         ;3 c-addr --    Z = 1 --> Not a Number : incr string count to add '?'
1724             MOV.B @TOS,Y            ;2              Y=count+1
1725             ADD TOS,Y               ;1              Y=end of string addr
1726             MOV.B #'?',0(Y)         ;5              add '?' to end of string
1727             MOV #FABORT_TERM,IP     ;2              define the return of COUNT
1728             JMP COUNT               ;2 -- addr len  35 words
1729 NotFound    .word   NotFoundExe     ;
1730
1731     .IFDEF CORE_COMPLEMENT
1732             FORTHWORD "EVALUATE"
1733 ; https://forth-standard.org/standard/core/EVALUATE
1734 ; EVALUATE          \ i*x c-addr u -- j*x  interpret string
1735 EVALUATE    MOV #SOURCE_LEN,X       ;2
1736             MOV @X+,S               ;2 S = SOURCE_LEN
1737             MOV @X+,T               ;2 T = SOURCE_ORG
1738             MOV @X+,W               ;2 W = TOIN
1739             PUSHM #4,IP             ;6 PUSHM IP,S,T,W
1740             ASMtoFORTH
1741             .word   INTERPRET
1742             .word   $+2
1743             MOV @RSP+,&TOIN         ;4
1744             MOV @RSP+,&SOURCE_ORG   ;4
1745             MOV @RSP+,&SOURCE_LEN   ;4
1746             MOV @RSP+,IP
1747             MOV @IP+,PC
1748
1749             FORTHWORD "BL"
1750 ; https://forth-standard.org/standard/core/BL
1751 ; BL      -- char            an ASCII space
1752     .ENDIF ; CORE_COMPLEMENT
1753 FBLANK       CALL rDOCON
1754             .word   20h
1755
1756             FORTHWORD "ALLOT"
1757 ; https://forth-standard.org/standard/core/ALLOT
1758 ; ALLOT   n --         allocate n bytes
1759 ALLOT       ADD TOS,&DDP
1760             MOV @PSP+,TOS
1761             MOV @IP+,PC
1762
1763 ;            FORTHWORD "ABORT"
1764 ; https://forth-standard.org/standard/core/ABORT
1765 ; Empty the data stack and perform the function of QUIT,
1766 ; which includes emptying the return stack, without displaying a message.
1767 ; ABORT is the common next of WARM and ABORT"
1768 ABORT       MOV #PSTACK,PSP         ;
1769             MOV #0,TOS              ; to reset first PSP cell (TOS), used next by WARM
1770 ; https://forth-standard.org/standard/core/QUIT
1771 ; QUIT  --     interpret line by line the input stream
1772 QUIT        MOV #RSTACK,RSP         ;
1773             MOV #LSTACK,&LEAVEPTR   ;
1774             MOV #0,&STATE           ;
1775             ASMtoFORTH
1776     .IFDEF PROMPT
1777 QUIT1       .word   XSQUOTE         ; background interpret loop
1778             .byte   5,13,10,"ok "   ; CR+LF + Forth prompt
1779 QUIT2       .word   TYPE            ; display it
1780     .ELSE
1781 QUIT2       .word   CR
1782     .ENDIF
1783 QUIT3       .word   REFILL          ; -- org len      refill input buffer from ACCEPT (one line)
1784 QUIT4       .word   INTERPRET       ; interpret this line|string
1785             .word   DEPTH,ZEROLESS  ; stack empty test
1786             .word   XSQUOTE         ; ABORT" stack empty! "
1787             .byte 12,"stack empty!" ;
1788             .word   QABORT          ; see QABORT in forthMSP430FR_TERM_xxx.asm
1789             .word   lit,FRAM_FULL   ;
1790             .word   HERE,ULESS      ; FRAM full test
1791             .word   XSQUOTE         ; ABORT" FRAM full! "
1792             .byte   10,"FRAM full!" ;
1793             .word   QABORT          ; see QABORT in forthMSP430FR_TERM_xxx.asm
1794     .IFDEF PROMPT
1795             .word   LIT,STATE,FETCH ; STATE @
1796             .word   QFBRAN,QUIT1    ; 0= case of interpretion state
1797             .word   XSQUOTE         ; 0<> case of compilation state
1798             .byte   5,13,10,"   "   ; CR+LF + 3 spaces
1799     .ENDIF
1800             .word   BRAN,QUIT2
1801
1802             FORTHWORDIMM "ABORT\34" ; immediate
1803 ; https://forth-standard.org/standard/core/ABORTq
1804 ; ABORT"  i*x flag -- i*x   R: j*x -- j*x  flag=0
1805 ;         i*x flag --       R: j*x --      flag<>0
1806 ; ABORT" " (empty string) displays nothing
1807 ABORTQUOTE  mDOCOL
1808             .word   SQUOTE
1809             .word   lit,QABORT,COMMA    ; see QABORT in forthMSP430FR_TERM_xxx.asm
1810             .word   EXIT
1811
1812 ;-------------------------------------------------------------------------------
1813 ; COMPILER
1814 ;-------------------------------------------------------------------------------
1815             FORTHWORD "'"
1816 ; https://forth-standard.org/standard/core/Tick
1817 ; '    -- xt           find word in dictionary and leave on stack its execution address
1818 TICK        mDOCOL
1819             .word   FBLANK,WORDD,FIND
1820             .word   QFBRAN,NotFound ; see INTERPRET
1821             .word   EXIT
1822
1823             FORTHWORDIMM "[']"      ; immediate word, i.e. word executed during compilation
1824 ; https://forth-standard.org/standard/core/BracketTick
1825 ; ['] <name>        --         find word & compile it as literal
1826 BRACTICK    mDOCOL
1827             .word   TICK            ; get xt of <name>
1828             .word   lit,lit,COMMA   ; append LIT action
1829             .word   COMMA,EXIT      ; append xt literal
1830
1831             FORTHWORDIMM "["    ; immediate
1832 ; https://forth-standard.org/standard/core/Bracket
1833 ; [        --      enter interpretative state
1834 LEFTBRACKET
1835             MOV #0,&STATE
1836             MOV @IP+,PC
1837
1838             FORTHWORD "]"
1839 ; https://forth-standard.org/standard/core/right-bracket
1840 ; ]        --      enter compiling state
1841 RIGHTBRACKET
1842             MOV  #-1,&STATE
1843             MOV @IP+,PC
1844
1845             FORTHWORDIMM "\\"       ; immediate
1846 ; https://forth-standard.org/standard/block/bs
1847 ; \         --      backslash
1848 ; everything up to the end of the current line is a comment.
1849 BACKSLASH   MOV &SOURCE_LEN,&TOIN   ;
1850             MOV @IP+,PC
1851
1852             FORTHWORDIMM "POSTPONE"
1853 ; https://forth-standard.org/standard/core/POSTPONE
1854 POSTPONE    mDOCOL
1855             .word   FBLANK,WORDD,FIND,QDUP
1856             .word   QFBRAN,NotFound ; see INTERPRET
1857             .word   ZEROLESS        ; immediate word ?
1858             .word   QFBRAN,POST1    ; if immediate
1859             .word   lit,lit,COMMA   ; else  compile lit
1860             .word   COMMA           ;       compile xt
1861             .word   lit,COMMA       ;       CFA of COMMA
1862 POST1       .word   COMMA,EXIT      ; then compile: if immediate xt of word found else CFA of COMMA
1863
1864             FORTHWORD ":"
1865 ; https://forth-standard.org/standard/core/Colon
1866 ; : <name>     --      begin a colon definition
1867 ; HEADER is CALLed by all compiling words
1868 COLON       PUSH #COLONNEXT         ;3 define COLONNEXT as HEADER return
1869 ;-----------------------------------;
1870 HEADER      BIT #1,&DDP             ;3              carry set if odd
1871             ADDC #2,&DDP            ;4              (DP+2|DP+3) bytes, make room for LFA
1872             mDOCOL                  ;
1873             .word FBLANK,WORDD      ;
1874             .word   $+2             ; -- HERE       HERE is the NFA of this new word
1875             MOV @RSP+,IP            ;
1876             MOV TOS,Y               ; -- NFA        Y=NFA
1877             MOV.B @TOS+,W           ; -- NFA+1      W=Count_of_chars
1878             BIS.B #1,W              ;               W=count is always odd
1879             ADD.B #1,W              ;               W=add one byte for length
1880             ADD Y,W                 ;               W=Aligned_CFA
1881             MOV &CURRENT,X          ;               X=VOC_BODY of CURRENT
1882     .SWITCH THREADS                 ;
1883     .CASE   1                       ;               nothing to do
1884     .ELSECASE                       ;               multithreading add 5~ 4words
1885             MOV.B @TOS,TOS          ; -- char       TOS=first CHAR of new word
1886             AND #(THREADS-1)*2,TOS  ; -- offset     TOS= Thread offset
1887             ADD TOS,X               ;               X=VOC_PFAx = thread x of VOC_PFA of CURRENT
1888     .ENDCASE                        ;
1889             MOV @PSP+,TOS           ; --
1890 HEADEREND   MOV Y,&LAST_NFA         ;               NFA --> LAST_NFA            used by QREVEAL, IMMEDIATE, MARKER
1891             MOV X,&LAST_THREAD      ;               VOC_PFAx --> LAST_THREAD    used by QREVEAL
1892             MOV W,&LAST_CFA         ;               HERE=CFA --> LAST_CFA       used by DOES>, RECURSE
1893             MOV PSP,&LAST_PSP       ;               save PSP for check compiling, used by QREVEAL
1894             ADD #4,W                ;               by default make room for two words...
1895             MOV W,&DDP              ;
1896             MOV @RSP+,PC            ; RET           W is the new DP value )
1897                                     ;               X is LAST_THREAD      > used by compiling words: CREATE, DEFER, :...
1898 COLONNEXT                           ;               Y is NFA              )
1899     .SWITCH DTC                     ; Direct Threaded Code select
1900     .CASE 1                         ;
1901             MOV #1284h,-4(W)        ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL)
1902             SUB #2,&DDP             ;
1903     .CASE 2                         ;
1904             MOV #120Dh,-4(W)        ; compile PUSH IP       3~
1905             MOV #1284h,-2(W)        ; compile CALL R4 = rDOCOL ([rDOCOL] = EXIT)
1906     .CASE 3                         ;
1907             MOV #120Dh,-4(W)        ; compile PUSH IP       3~
1908             MOV #400Dh,-2(W)        ; compile MOV PC,IP     1~
1909             MOV #522Dh,0(W)         ; compile ADD #4,IP     1~
1910             MOV #4D30h,+2(W)        ; compile MOV @IP+,PC   4~
1911             ADD #4,&DDP             ;
1912     .ENDCASE                        ;
1913             MOV #-1,&STATE          ; enter compiling state
1914             MOV @IP+,PC             ;
1915 ;-----------------------------------;
1916
1917 ;;Z ?REVEAL   --      if no stack mismatch, link this new word in the CURRENT vocabulary
1918 QREVEAL     CMP PSP,&LAST_PSP       ; Check SP with its saved value by :, :NONAME, CODE...
1919             JNZ BAD_CSP             ; if stack mismatch.
1920 GOOD_CSP    MOV &LAST_NFA,Y         ;
1921             MOV &LAST_THREAD,X      ;
1922 REVEAL      MOV @X,-2(Y)            ; [LAST_THREAD] --> LFA         (for NONAME: [LAST_THREAD] --> unused PA reg)
1923             MOV Y,0(X)              ; LAST_NFA --> [LAST_THREAD]    (for NONAME: LAST_NFA --> unused PA reg)
1924             MOV @IP+,PC
1925
1926 BAD_CSP     mDOCOL
1927             .word   XSQUOTE
1928             .byte   15,"stack mismatch!"
1929 FABORT_TERM .word   ABORT_TERM
1930
1931             FORTHWORDIMM ";"
1932 ; https://forth-standard.org/standard/core/Semi
1933 ; ;            --      end a colon definition
1934 SEMICOLON   CMP #0,&STATE           ; if interpret mode, semicolon becomes a comment identifier
1935             JZ BACKSLASH            ; tip: ";" is transparent to the preprocessor, so semicolon comments are kept in file.4th
1936             mDOCOL                  ; compile mode
1937             .word   lit,EXIT,COMMA
1938             .word   QREVEAL,LEFTBRACKET,EXIT
1939
1940             FORTHWORD "IMMEDIATE"
1941 ; https://forth-standard.org/standard/core/IMMEDIATE
1942 ; IMMEDIATE        --   make last definition immediate
1943 IMMEDIATE   MOV &LAST_NFA,Y         ; Y = NFA|unused_PA_reg as lure for :NONAME
1944             BIS.B #BIT7,0(Y)        ;
1945             MOV @IP+,PC
1946
1947             FORTHWORD "CREATE"
1948 ; https://forth-standard.org/standard/core/CREATE
1949 ; CREATE <name>        --          define a CONSTANT with its next address
1950 ; Execution: ( -- a-addr )          ; a-addr is the address of name's data field
1951 ;                                   ; the execution semantics of name may be extended by using DOES>
1952 CREATE      CALL #HEADER            ; --        W = DDP
1953             MOV #1286h,-4(W)        ;4          -4(W) = CFA = CALL R6 = rDOCON
1954             MOV W,-2(W)             ;3          -2(W) = PFA = W = next address
1955             JMP REVEAL              ;           to link the definition in vocabulary
1956
1957     .IFDEF CORE_COMPLEMENT
1958             FORTHWORD "DOES>"
1959 ; https://forth-standard.org/standard/core/DOES
1960 ; DOES>    --          set action for the latest CREATEd definition
1961 DOES        MOV &LAST_CFA,W         ;           W = CFA of CREATEd word
1962             MOV #1285h,0(W)         ;           replace old CFA of CREATE by new CFA CALL R5 = rDODOES
1963             MOV IP,2(W)             ;           replace PFA by the address after DOES> as execution address
1964             MOV @RSP+,IP            ;
1965             MOV @IP+,PC             ;           exit of the new created word
1966
1967             FORTHWORD "CONSTANT"
1968 ;https://forth-standard.org/standard/core/CONSTANT
1969 ;C CONSTANT <name>     n --                      define a Forth CONSTANT
1970 CONSTANT    CALL #HEADER            ;       W = DDP = CFA + 2 words
1971             MOV #1286h,-4(W)        ;       CFA = CALL R6 = rDOCON
1972             MOV TOS,-2(W)           ;       PFA = n
1973             MOV @PSP+,TOS           ; --
1974             JMP REVEAL              ;       to link the definition in vocabulary
1975
1976             FORTHWORD "VARIABLE"
1977 ;https://forth-standard.org/standard/core/VARIABLE
1978 ;C VARIABLE <name>       --                      define a Forth VARIABLE
1979 VARIABLE    CALL #HEADER            ; W = DDP = CFA + 2 words
1980             MOV #1287h,-4(W)        ; CFA = CALL R7 = rDOVAR, PFA is undefined
1981             JMP REVEAL              ; to link created VARIABLE in vocabulary
1982
1983     .ENDIF ; CORE_COMPLEMENT
1984
1985     .IFDEF DEFERRED
1986             FORTHWORD ":NONAME"
1987 ; https://forth-standard.org/standard/core/ColonNONAME
1988 ; :NONAME        -- xt
1989 ; W is DP
1990 ; X is the LAST_THREAD lure value for REVEAL
1991 ; Y is the LAST_NFA lure value for REVEAL and IMMEDIATE
1992 ; ...because we don't want to modify the word set !
1993             PUSH #COLONNEXT         ; define COLONNEXT as HEADERLESS RET
1994 HEADERLESS  SUB #2,PSP              ; common part of :NONAME and CODENNM
1995             MOV TOS,0(PSP)          ;
1996             MOV &DDP,W              ;
1997             BIT #1,W                ;
1998             ADDC #0,W               ;           W = aligned CFA
1999             MOV W,TOS               ; -- xt     aligned CFA of :NONAME | CODENNM
2000             MOV #210h,X             ;           X = 210h = unused PA register address (lure for REVEAL)
2001             MOV X,Y                 ;1
2002             ADD #2,Y                ;1          Y = 212h = unused PA register address (lure for REVEAL and IMMEDIATE)
2003             JMP HEADEREND           ;
2004
2005 ; https://forth-standard.org/standard/core/DEFER
2006 ; Skip leading space delimiters. Parse name delimited by a space.
2007 ; Create a definition for name with the execution semantics defined below.
2008 ;
2009 ; name Execution:   --
2010 ; Execute the xt that name is set to execute, i.e. NEXT (nothing),
2011 ; until the phrase ' word IS name is executed, causing a new value of xt to be assigned to name.
2012             FORTHWORD "DEFER"
2013             CALL #HEADER
2014             MOV #4030h,-4(W)        ;4 first CELL = MOV @PC+,PC = BR...
2015             MOV #NEXT_ADR,-2(W)     ;3 second CELL              =   ...mNEXT : do nothing by default
2016             JMP REVEAL              ; to link created word in vocabulary
2017
2018 ; DEFER! ( xt CFA_DEFERed_WORD -- )
2019 ;            FORTHWORD "DEFER!"
2020 DEFERSTORE  MOV @PSP+,2(TOS)        ; -- CFA_DEFERed_WORD          xt --> [PFA_DEFERed_WORD]
2021             MOV @PSP+,TOS           ; --
2022             MOV @IP+,PC             ;
2023
2024 ; IS <name>        xt --
2025 ; used like this:
2026 ; DEFER DISPLAY                         create a "do nothing" definition (2 CELLS)
2027 ; inline command : ' U. IS DISPLAY      U. becomes the runtime of the word DISPLAY
2028 ; or in a definition : ... ['] U. IS DISPLAY ...
2029 ; KEY, EMIT, CR, ACCEPT and WARM are examples of DEFERred words
2030             FORTHWORDIMM "IS"       ; immediate
2031 IS          PUSH IP
2032             CMP #0,&STATE
2033             JZ IS_EXEC
2034 IS_COMPILE  ASMtoFORTH
2035             .word   BRACTICK             ; find the word, compile its CFA as literal
2036             .word   lit,DEFERSTORE,COMMA ; compile DEFERSTORE
2037             .word   EXIT
2038 IS_EXEC     ASMtoFORTH
2039             .word   TICK,DEFERSTORE     ; find the word, leave its CFA on the stack and execute DEFERSTORE
2040             .word   EXIT
2041
2042     .ENDIF ; DEFERRED
2043
2044     .IFDEF MSP430ASSEMBLER
2045
2046            FORTHWORD "CODE"         ; a CODE word must be finished with ENDCODE
2047 ASMCODE     CALL #HEADER            ; (that sets CFA and PFA)
2048 ASMCODE1    SUB #4,&DDP             ; remove default CFA and PFA
2049 ASMCODE2
2050     .IFDEF EXTENDED_ASM
2051             MOV #0,&RPT_WORD        ; clear RPT instruction
2052     .ENDIF
2053             mDOCOL
2054             .word   ALSO,ASSEMBLER,EXIT
2055
2056 ; HDNCODE (hidden CODE) is used to define a CODE word which must not to be executed by FORTH interpreter
2057 ; i.e. typically an assembler word called by CALL and ended by RET, or an interrupt routine ended by RETI.
2058 ; ASM words are only usable in ASSEMBLER defined words
2059             FORTHWORD "HDNCODE"
2060             MOV #BODYASSEMBLER,&CURRENT ; select ASSEMBLER word set to link this HDNCODE definition
2061             JMP ASMCODE
2062
2063             asmword "ENDCODE"       ; test PSP balancing then restore previous CONTEXT
2064 ENDCODE     mDOCOL                  ; and set CURRENT = CONTEXT (to also end ASM definitions)
2065             .word   QREVEAL
2066 ENDCODE1    .word   PREVIOUS,DEFINITIONS,EXIT
2067
2068         .IFDEF DEFERRED
2069             FORTHWORD "CODENNM"     ; CODENoNaMe is the assembly counterpart of :NONAME
2070 CODENNM     PUSH #ASMCODE1          ; define HEADERLESS return
2071             JMP HEADERLESS          ; that makes room for CFA and PFA
2072         .ENDIF
2073
2074 ; here are 3 words used to switch FORTH <--> ASSEMBLER
2075
2076 ; COLON --      compile DOCOL, remove ASSEMBLER from CONTEXT and CURRENT, switch to compilation state
2077             asmword "COLON"
2078             MOV &DDP,W
2079     .SWITCH DTC
2080     .CASE 1
2081             MOV #1284h,0(W)         ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL)
2082             ADD #2,&DDP
2083     .CASE 2
2084             MOV #120Dh,0(W)         ; compile PUSH IP
2085 COLON1      MOV #1284h,2(W)         ; compile CALL R4 = rDOCOL
2086             ADD #4,&DDP
2087     .CASE 3 ; inlined DOCOL
2088             MOV #120Dh,0(W)         ; compile PUSH IP
2089 COLON1      MOV #400Dh,2(W)         ; compile MOV PC,IP
2090             MOV #522Dh,4(W)         ; compile ADD #4,IP
2091             MOV #4D30h,6(W)         ; compile MOV @IP+,PC
2092             ADD #8,&DDP             ;
2093     .ENDCASE ; DTC
2094
2095 COLON2      MOV #-1,&STATE          ; enter in compile state
2096             mDOCOL
2097             .word   PREVIOUS,DEFINITIONS,EXIT ; restore previous CONTEXT and set CURRENT = CONTEXT
2098
2099 ; LO2HI --       same as COLON but without saving IP
2100             asmword "LO2HI"
2101     .SWITCH DTC
2102     .CASE 1                         ; compile 2 words
2103             MOV &DDP,W
2104             MOV #12B0h,0(W)         ; compile CALL #EXIT, 2 words  4+6=10~
2105             MOV #EXIT,2(W)
2106             ADD #4,&DDP
2107             JMP COLON2
2108     .ELSECASE                       ; CASE 2 : compile 1 word, CASE 3 : compile 3 words
2109             SUB #2,&DDP             ; to skip PUSH IP
2110             MOV &DDP,W
2111             JMP COLON1
2112     .ENDCASE
2113
2114 ; HI2LO --       immediate, switch to low level, set interpretation state, add ASSEMBLER to CONTEXT
2115             FORTHWORDIMM "HI2LO"    ;
2116             mDOCOL
2117             .word   HERE,CELLPLUS,COMMA ; compile HERE+2
2118             .word   LEFTBRACKET         ; switch to interpret state
2119             .word   ASMCODE2            ; add ASSEMBLER in context
2120             .word   EXIT
2121
2122     .ENDIF ; MSP430ASSEMBLER
2123
2124     .IFDEF CONDCOMP
2125 ; ------------------------------------------------------------------------------
2126 ; forthMSP430FR :  CONDITIONNAL COMPILATION
2127 ; ------------------------------------------------------------------------------
2128         .include "forthMSP430FR_CONDCOMP.asm"
2129     .ENDIF
2130
2131         .IFDEF CORE_COMPLEMENT
2132 ; ------------------------------------------------------------------------------
2133 ; CONTROL STRUCTURES
2134 ; ------------------------------------------------------------------------------
2135 ; THEN and BEGIN compile nothing
2136 ; DO compile one word
2137 ; IF, ELSE, AGAIN, UNTIL, WHILE, REPEAT, LOOP & +LOOP compile two words
2138 ; LEAVE compile three words
2139
2140             FORTHWORDIMM "IF"       ; immediate
2141 ; https://forth-standard.org/standard/core/IF
2142 ; IF       -- IFadr    initialize conditional forward branch
2143 IFF         SUB #2,PSP              ;
2144             MOV TOS,0(PSP)          ;
2145             MOV &DDP,TOS            ; -- HERE
2146             ADD #4,&DDP             ;           compile one word, reserve one word
2147             MOV #QFBRAN,0(TOS)      ; -- HERE   compile QFBRAN
2148         .ENDIF ; CORE_COMPLEMENT
2149 CELLPLUS    ADD #2,TOS              ; -- HERE+2=IFadr
2150             MOV @IP+,PC
2151
2152         .IFDEF CORE_COMPLEMENT
2153             FORTHWORDIMM "ELSE"     ; immediate
2154 ; https://forth-standard.org/standard/core/ELSE
2155 ; ELSE     IFadr -- ELSEadr        resolve forward IF branch, leave ELSEadr on stack
2156 ELSS        ADD #4,&DDP             ; make room to compile two words
2157             MOV &DDP,W              ; W=HERE+4
2158             MOV #BRAN,-4(W)
2159             MOV W,0(TOS)            ; HERE+4 ==> [IFadr]
2160             SUB #2,W                ; HERE+2
2161             MOV W,TOS               ; -- ELSEadr
2162             MOV @IP+,PC
2163
2164             FORTHWORDIMM "THEN"     ; immediate
2165 ; https://forth-standard.org/standard/core/THEN
2166 ; THEN     IFadr --                resolve forward branch
2167 THEN        MOV &DDP,0(TOS)         ; -- IFadr
2168             MOV @PSP+,TOS           ; --
2169             MOV @IP+,PC
2170
2171             FORTHWORDIMM "BEGIN"    ; immediate
2172 ; https://forth-standard.org/standard/core/BEGIN
2173 ; BEGIN    -- BEGINadr             initialize backward branch
2174             MOV #HERE,PC            ; -- HERE
2175
2176             FORTHWORDIMM "UNTIL"    ; immediate
2177 ; https://forth-standard.org/standard/core/UNTIL
2178 ; UNTIL    BEGINadr --             resolve conditional backward branch
2179 UNTIL       MOV #QFBRAN,X
2180 UNTIL1      ADD #4,&DDP             ; compile two words
2181             MOV &DDP,W              ; W = HERE
2182             MOV X,-4(W)             ; compile Bran or QFBRAN at HERE
2183             MOV TOS,-2(W)           ; compile bakcward adr at HERE+2
2184             MOV @PSP+,TOS
2185             MOV @IP+,PC
2186
2187             FORTHWORDIMM "AGAIN"    ; immediate
2188 ; https://forth-standard.org/standard/core/AGAIN
2189 ;X AGAIN    BEGINadr --             resolve uncondionnal backward branch
2190 AGAIN       MOV #BRAN,X
2191             JMP UNTIL1
2192
2193             FORTHWORDIMM "WHILE"    ; immediate
2194 ; https://forth-standard.org/standard/core/WHILE
2195 ; WHILE    BEGINadr -- WHILEadr BEGINadr
2196 WHILE       mDOCOL
2197             .word   IFF,SWAP,EXIT
2198
2199             FORTHWORDIMM "REPEAT"   ; immediate
2200 ; https://forth-standard.org/standard/core/REPEAT
2201 ; REPEAT   WHILEadr BEGINadr --     resolve WHILE loop
2202 REPEAT      mDOCOL
2203             .word   AGAIN,THEN,EXIT
2204
2205             FORTHWORDIMM "DO"       ; immediate
2206 ; https://forth-standard.org/standard/core/DO
2207 ; DO       -- DOadr   L: -- 0
2208 DO          SUB #2,PSP              ;
2209             MOV TOS,0(PSP)          ;
2210             ADD #2,&DDP             ;   make room to compile xdo
2211             MOV &DDP,TOS            ; -- HERE+2
2212             MOV #xdo,-2(TOS)        ;   compile xdo
2213             ADD #2,&LEAVEPTR        ; -- HERE+2     LEAVEPTR+2
2214             MOV &LEAVEPTR,W         ;
2215             MOV #0,0(W)             ; -- HERE+2     L-- 0
2216             MOV @IP+,PC
2217
2218             FORTHWORD "I"
2219 ; https://forth-standard.org/standard/core/I
2220 ; I        -- n   R: sys1 sys2 -- sys1 sys2
2221 ;                  get the innermost loop index
2222 II          SUB #2,PSP              ;1 make room in TOS
2223             MOV TOS,0(PSP)          ;3
2224             MOV @RSP,TOS            ;2 index = loopctr - fudge
2225             SUB 2(RSP),TOS          ;3
2226             MOV @IP+,PC             ;4 13~
2227
2228             FORTHWORDIMM "LOOP"     ; immediate
2229 ; https://forth-standard.org/standard/core/LOOP
2230 ; LOOP    DOadr --         L-- an an-1 .. a1 0
2231 LOO         MOV #xloop,X
2232 LOOPNEXT    ADD #4,&DDP             ; make room to compile two words
2233             MOV &DDP,W
2234             MOV X,-4(W)             ; xloop --> HERE
2235             MOV TOS,-2(W)           ; DOadr --> HERE+2
2236 ; resolve all "leave" adr
2237 LEAVELOOP   MOV &LEAVEPTR,TOS       ; -- Adr of top LeaveStack cell
2238             SUB #2,&LEAVEPTR        ; --
2239             MOV @TOS,TOS            ; -- first LeaveStack value
2240             CMP #0,TOS              ; -- = value left by DO ?
2241             JZ LOOPEND
2242             MOV W,0(TOS)            ; move adr after loop as UNLOOP adr
2243             JMP LEAVELOOP
2244 LOOPEND     MOV @PSP+,TOS
2245             MOV @IP+,PC
2246
2247             FORTHWORDIMM "+LOOP"    ; immediate
2248 ; https://forth-standard.org/standard/core/PlusLOOP
2249 ; +LOOP   adrs --   L-- an an-1 .. a1 0
2250 PLUSLOOP    MOV #xploop,X
2251             JMP LOOPNEXT
2252     .ENDIF ; CORE_COMPLEMENT
2253
2254     .IFDEF VOCABULARY_SET
2255 ;-------------------------------------------------------------------------------
2256 ; WORDS SET for VOCABULARY, not ANS compliant
2257 ;-------------------------------------------------------------------------------
2258         .IFNDEF DOES
2259             FORTHWORD "DOES>"
2260 ; https://forth-standard.org/standard/core/DOES
2261 ; DOES>    --          set action for the latest CREATEd definition
2262 DOES        MOV &LAST_CFA,W         ;           W = CFA of CREATEd word
2263             MOV #1285h,0(W)         ;           replace CFA (DOCON) by new CFA (DODOES)
2264             MOV IP,2(W)             ;           replace PFA by the address after DOES> as execution address
2265             MOV @RSP+,IP            ;
2266             MOV @IP+,PC             ;           exit of the new created word
2267         .ENDIF
2268
2269             FORTHWORD "VOCABULARY"
2270 ;X VOCABULARY       -- create a vocabulary, up to 7 vocabularies in CONTEXT
2271 VOCABULARY  mDOCOL
2272             .word   CREATE
2273         .SWITCH THREADS
2274         .CASE   1
2275             .word   lit,0,COMMA     ; will keep the NFA of the last word of the future created vocabularies
2276         .ELSECASE
2277             .word   lit,THREADS,lit,0,xdo
2278 VOCABULOOP  .word   lit,0,COMMA
2279             .word   xloop,VOCABULOOP
2280         .ENDCASE
2281             .word   HERE            ; link via LASTVOC the future created vocabulary
2282             .word   LIT,LASTVOC,DUP
2283             .word   FETCH,COMMA     ; compile [LASTVOC] to HERE+
2284             .word   STORE           ; store (HERE - 2) to LASTVOC
2285             .word   DOES            ; compile CFA and PFA for the future defined vocabulary
2286     .ENDIF ; VOCABULARY_SET
2287 VOCDOES     .word   LIT,CONTEXT,STORE
2288             .word   EXIT
2289
2290     .IFDEF VOCABULARY_SET
2291             FORTHWORD "FORTH"
2292     .ENDIF ; VOCABULARY_SET
2293 ;X  FORTH    --                     ; set FORTH the first context vocabulary; FORTH must be the first vocabulary
2294 FORTH                               ; leave BODYFORTH on the stack and run VOCDOES
2295             CALL rDODOES            ; Code Field Address (CFA) of FORTH
2296 PFAFORTH    .word   VOCDOES         ; Parameter Field Address (PFA) of FORTH
2297 BODYFORTH                           ; BODY of FORTH
2298             .word   lastforthword
2299     .SWITCH THREADS
2300     .CASE   2
2301             .word   lastforthword1
2302     .CASE   4
2303             .word   lastforthword1
2304             .word   lastforthword2
2305             .word   lastforthword3
2306     .CASE   8
2307             .word   lastforthword1
2308             .word   lastforthword2
2309             .word   lastforthword3
2310             .word   lastforthword4
2311             .word   lastforthword5
2312             .word   lastforthword6
2313             .word   lastforthword7
2314     .CASE   16
2315             .word   lastforthword1
2316             .word   lastforthword2
2317             .word   lastforthword3
2318             .word   lastforthword4
2319             .word   lastforthword5
2320             .word   lastforthword6
2321             .word   lastforthword7
2322             .word   lastforthword8
2323             .word   lastforthword9
2324             .word   lastforthword10
2325             .word   lastforthword11
2326             .word   lastforthword12
2327             .word   lastforthword13
2328             .word   lastforthword14
2329             .word   lastforthword15
2330     .CASE   32
2331             .word   lastforthword1
2332             .word   lastforthword2
2333             .word   lastforthword3
2334             .word   lastforthword4
2335             .word   lastforthword5
2336             .word   lastforthword6
2337             .word   lastforthword7
2338             .word   lastforthword8
2339             .word   lastforthword9
2340             .word   lastforthword10
2341             .word   lastforthword11
2342             .word   lastforthword12
2343             .word   lastforthword13
2344             .word   lastforthword14
2345             .word   lastforthword15
2346             .word   lastforthword16
2347             .word   lastforthword17
2348             .word   lastforthword18
2349             .word   lastforthword19
2350             .word   lastforthword20
2351             .word   lastforthword21
2352             .word   lastforthword22
2353             .word   lastforthword23
2354             .word   lastforthword24
2355             .word   lastforthword25
2356             .word   lastforthword26
2357             .word   lastforthword27
2358             .word   lastforthword28
2359             .word   lastforthword29
2360             .word   lastforthword30
2361             .word   lastforthword31
2362     .ELSECASE
2363     .ENDCASE
2364             .word   voclink
2365 voclink     .set    $-2
2366
2367     .IFDEF MSP430ASSEMBLER
2368     .IFDEF VOCABULARY_SET
2369             FORTHWORD "ASSEMBLER"
2370     .ENDIF ; VOCABULARY_SET
2371 ;X  ASSEMBLER       --              ; set ASSEMBLER the first context vocabulary
2372 ASSEMBLER   CALL rDODOES        ; leave BODYASSEMBLER on the stack and run VOCDOES
2373                 .word   VOCDOES
2374 BODYASSEMBLER
2375             .word   lastasmword
2376     .SWITCH THREADS
2377     .CASE   2
2378             .word   lastasmword1
2379     .CASE   4
2380             .word   lastasmword1
2381             .word   lastasmword2
2382             .word   lastasmword3
2383     .CASE   8
2384             .word   lastasmword1
2385             .word   lastasmword2
2386             .word   lastasmword3
2387             .word   lastasmword4
2388             .word   lastasmword5
2389             .word   lastasmword6
2390             .word   lastasmword7
2391     .CASE   16
2392             .word   lastasmword1
2393             .word   lastasmword2
2394             .word   lastasmword3
2395             .word   lastasmword4
2396             .word   lastasmword5
2397             .word   lastasmword6
2398             .word   lastasmword7
2399             .word   lastasmword8
2400             .word   lastasmword9
2401             .word   lastasmword10
2402             .word   lastasmword11
2403             .word   lastasmword12
2404             .word   lastasmword13
2405             .word   lastasmword14
2406             .word   lastasmword15
2407     .CASE   32
2408             .word   lastasmword1
2409             .word   lastasmword2
2410             .word   lastasmword3
2411             .word   lastasmword4
2412             .word   lastasmword5
2413             .word   lastasmword6
2414             .word   lastasmword7
2415             .word   lastasmword8
2416             .word   lastasmword9
2417             .word   lastasmword10
2418             .word   lastasmword11
2419             .word   lastasmword12
2420             .word   lastasmword13
2421             .word   lastasmword14
2422             .word   lastasmword15
2423             .word   lastasmword16
2424             .word   lastasmword17
2425             .word   lastasmword18
2426             .word   lastasmword19
2427             .word   lastasmword20
2428             .word   lastasmword21
2429             .word   lastasmword22
2430             .word   lastasmword23
2431             .word   lastasmword24
2432             .word   lastasmword25
2433             .word   lastasmword26
2434             .word   lastasmword27
2435             .word   lastasmword28
2436             .word   lastasmword29
2437             .word   lastasmword30
2438             .word   lastasmword31
2439     .ELSECASE
2440     .ENDCASE
2441             .word   voclink
2442 voclink     .set    $-2
2443     .ENDIF ; MSP430ASSEMBLER
2444
2445     .IFDEF VOCABULARY_SET
2446             FORTHWORD "ALSO"
2447     .ENDIF ; VOCABULARY_SET
2448 ;X  ALSO    --                  make room to put a vocabulary as first in context
2449 ALSO        MOV #12,W               ; -- move up 6 words, 8th word of CONTEXT area must remain to 0
2450             MOV #CONTEXT+12,X       ; X=src
2451             MOV X,Y
2452             ADD #2,Y                ; Y=dst
2453 MOVEUP      SUB #1,X
2454             SUB #1,Y
2455             MOV.B @X,0(Y)           ; if X=src < Y=dst copy W bytes beginning with the end
2456             SUB #1,W
2457             JNZ MOVEUP
2458             MOV @IP+,PC
2459
2460     .IFDEF VOCABULARY_SET
2461             FORTHWORD "PREVIOUS"
2462     .ENDIF ; VOCABULARY_SET
2463 ;X  PREVIOUS   --               pop last vocabulary out of context
2464 PREVIOUS    MOV #14,W               ; move down 7 words, first with the 8th word equal to 0
2465             MOV #CONTEXT,Y          ; Y=dst
2466             MOV Y,X
2467             ADD #2,X                ; X=src
2468 MOVEDOWN    MOV.B @X+,0(Y)          ; if X=src > Y=dst copy W bytes
2469             ADD #1,Y
2470             SUB #1,W
2471             JNZ MOVEDOWN
2472 MOVEND      MOV @IP+,PC
2473
2474     .IFDEF VOCABULARY_SET
2475             FORTHWORD "ONLY"
2476     .ENDIF ; VOCABULARY_SET
2477 ;X ONLY     --      cut context list to access only first vocabulary, ex.: FORTH ONLY
2478 ONLY        MOV #0,&CONTEXT+2
2479             MOV @IP+,PC
2480
2481     .IFDEF VOCABULARY_SET
2482             FORTHWORD "DEFINITIONS"
2483     .ENDIF ; VOCABULARY_SET
2484 ;X DEFINITIONS  --      set last context vocabulary as entry for further defining words
2485 DEFINITIONS MOV &CONTEXT,&CURRENT
2486             MOV @IP+,PC
2487
2488     .IFDEF USE_MOVE ; if UTILITY.asm|ANS_COMP.asm
2489             FORTHWORD "MOVE"
2490 ; https://forth-standard.org/standard/core/MOVE
2491 ; MOVE    addr1 addr2 u --     smart move
2492 ;             VERSION FOR 1 ADDRESS UNIT = 1 CHAR
2493 MOVE        MOV TOS,W               ; W = cnt
2494             MOV @PSP+,Y             ; Y = addr2 = dst
2495             MOV @PSP+,X             ; X = addr1 = src
2496             MOV @PSP+,TOS           ; pop new TOS
2497             CMP #0,W                ; count = 0 ?
2498             JZ MOVEND               ; already done !
2499             CMP X,Y                 ; Y=dst = X=src ?
2500             JZ MOVEND               ; already done !
2501             JNC MOVEDOWN            ; if Y=dst < X=src ; see PREVIOUS
2502             ADD W,Y                 ; move beginning with the end
2503             ADD W,X                 ;
2504             JMP MOVEUP              ; if Y=dst > X=src ; see ALSO
2505     .ENDIF
2506
2507 ;-------------------------------------------------------------------------------
2508 ; MEMORY MANAGEMENT
2509 ;-------------------------------------------------------------------------------
2510 STATE_DOES  ; execution part of PWR_STATE ; sorry, doesn't restore search order pointers
2511             .word   FORTH,ONLY,DEFINITIONS
2512             .word   $+2             ; -- BODY       IP is free
2513     .IFDEF VOCABULARY_SET
2514             MOV @TOS+,W             ; -- BODY+2     W = old VOCLINK = VLK
2515     .ELSE
2516             MOV &WIPE_VOC,W         ;               W = VOCLINK = VLK
2517     .ENDIF
2518             MOV W,&LASTVOC          ;               restore (or init) LASTVOC in RAM
2519             MOV @TOS,TOS            ; -- OLD_DP
2520             MOV TOS,&DDP            ; -- DP         restore (or init) DP in RAM
2521                                     ; then restore words link(s) with their value < old DP
2522     .SWITCH THREADS
2523     .CASE   1 ; mono thread vocabularies
2524 MARKALLVOC  MOV W,Y                 ; -- DP         W=VLK   Y=VLK
2525 MRKWORDLOOP MOV -2(Y),Y             ; -- DP         W=VLK   Y=NFA
2526             CMP Y,TOS               ; -- DP         CMP = TOS-Y : OLD_DP-NFA
2527             JNC MRKWORDLOOP         ;               loop back if TOS<Y : OLD_DP<NFA
2528             MOV Y,-2(W)             ;               W=VLK   X=THD   Y=NFA   refresh thread with good NFA
2529             MOV @W,W                ; -- DP         W=[VLK] = next voclink
2530             CMP #0,W                ; -- DP         W=[VLK] = next voclink   end of vocs ?
2531             JNZ MARKALLVOC          ; -- DP         W=VLK                   no : loopback
2532     .ELSECASE ; multi threads vocabularies
2533 MARKALLVOC  MOV #THREADS,IP         ; -- DP         W=VLK
2534             MOV W,X                 ; -- DP         W=VLK   X=VLK
2535 MRKTHRDLOOP MOV X,Y                 ; -- DP         W=VLK   X=VLK   Y=VLK
2536             SUB #2,X                ; -- DP         W=VLK   X=THD (thread ((case-2)to0))
2537 MRKWORDLOOP MOV -2(Y),Y             ; -- DP         W=VLK   Y=NFA
2538             CMP Y,TOS               ; -- DP         CMP = TOS-Y : DP-NFA
2539             JNC MRKWORDLOOP         ;               loop back if TOS<Y : DP<NFA
2540 MARKTHREAD  MOV Y,0(X)              ;               W=VLK   X=THD   Y=NFA   refresh thread with good NFA
2541             SUB #1,IP               ; -- DP         W=VLK   X=THD   Y=NFA   IP=CFT-1
2542             JNZ MRKTHRDLOOP         ;                       loopback to compare NFA in next thread (thread-1)
2543             MOV @W,W                ; -- DP         W=[VLK] = next voclink
2544             CMP #0,W                ; -- DP         W=[VLK] = next voclink   end of vocs ?
2545             JNZ MARKALLVOC          ; -- DP         W=VLK                   no : loopback
2546     .ENDCASE ; of THREADS           ; -- DP
2547             MOV @PSP+,TOS           ;
2548             MOV @RSP+,IP            ;
2549 NEXT_ADR    MOV @IP+,PC             ;
2550
2551 ;-------------------------------------------------------------------------------
2552 ; FASTFORTH START: set DP, VOCLINK, CURRENT and CONTEXT
2553 ;-------------------------------------------------------------------------------
2554             FORTHWORD "PWR_STATE"   ; executed by POWER_ON and ABORT_TERM; does PWR_HERE word set
2555 PWR_STATE   CALL rDODOES            ; DOES part of MARKER : resets pointers DP, voclink
2556             .word   STATE_DOES      ; execution vector of PWR_STATE
2557     .IFDEF VOCABULARY_SET
2558 MARKVOC     .word   lastvoclink     ; initialised by forthMSP430FR.asm as voclink value
2559     .ENDIF
2560 MARKDP      .word   ROMDICT         ; initialised by forthMSP430FR.asm as DP value
2561
2562             FORTHWORD "RST_STATE"   ; executed by <reset>, COLD, SYSRSTIV error; does RST_HERE word set
2563 RST_STATE   MOV &RST_DP,&MARKDP     ; INIT value above (FRAM value)
2564     .IFDEF VOCABULARY_SET
2565             MOV &RST_VOC,&MARKVOC   ; INIT value above (FRAM value)
2566     .ENDIF
2567             JMP PWR_STATE
2568
2569             FORTHWORD "PWR_HERE"    ; define word set bound for POWER_ON, ABORT_TERM.
2570 PWR_HERE    MOV &DDP,&MARKDP
2571     .IFDEF VOCABULARY_SET
2572             MOV &LASTVOC,&MARKVOC
2573     .ENDIF
2574             MOV @IP+,PC
2575
2576             FORTHWORD "RST_HERE"    ; define word set bound for <reset>, COLD, SYSRSTIV error.
2577 RST_HERE    MOV &DDP,&RST_DP
2578     .IFDEF VOCABULARY_SET
2579             MOV &LASTVOC,&RST_VOC
2580     .ENDIF
2581             JMP PWR_HERE            ; and obviously the same for POWER_ON...
2582
2583 ;-------------------------------------------------------------------------------
2584 ; PUC 6.2: SELECT PWR_STATE|RST_STATE|DEEP_RESET       <== INI_FORTH
2585 ;-------------------------------------------------------------------------------
2586 SEL_P_R_D   CMP #0Eh,TOS            ;
2587             JZ PWR_STATE            ; if RSTIV_MEM = 14 (SYSSVSH event)
2588             CMP #4,TOS              ;
2589             JGE RST_STATE           ; if RSTIV_MEM >= 4 (RESET,COLD,SYS_FAILURES)
2590             CMP #0,TOS              ;
2591             JGE PWR_STATE           ; if RSTIV_MEM >= 0 (POWER_ON,WARM,ABORT")
2592 ;-----------------------------------;
2593 ; DEEP RESET                        ; if RSTIV_MEM < 0
2594 ;-----------------------------------;
2595 ; INIT SIGNATURES AREA              ;
2596 ;-----------------------------------;
2597             MOV #16,X               ; max known SIGNATURES length = 12 bytes
2598 SIGNATLOOP  SUB #2,X                ;
2599             MOV #-1,SIGNATURES(X)   ; reset signature; WARNING ! DON'T CHANGE IMMEDIATE VALUE !
2600             JNZ SIGNATLOOP          ;
2601 ;-----------------------------------; X = 0 ;-)
2602 ; INIT VECTORS INT                  ;
2603 ;-----------------------------------;
2604             MOV #RESET,-2(X)        ; write RESET at addr X-2 = FFFEh
2605 INIVECLOOP  SUB #2,X                ;
2606             MOV #COLD,-2(X)         ; -2(X) = FFFCh first
2607             CMP #0FFAEh,X           ; init 41 vectors, FFFCh down to 0FFACh
2608             JNZ INIVECLOOP          ; all vectors are initialised to execute COLD routine
2609 ;-----------------------------------;
2610 ; INIT all "CALL #xxx_APP"          ;
2611 ;-----------------------------------;
2612             MOV #WIPE_INI,X         ; WIPE_INI constants are in FRAM INFO
2613             MOV @X+,&PFACOLD        ; COLD_TERM             as default COLD_APP     --> PFACOLD
2614             MOV @X+,&PFA_INI_FORTH  ; RET_ADR|INI_FORTH_SD  as default INI_SOFT_APP --> PFA_INI_FORTH
2615             MOV @X+,&PFASLEEP       ; RXON                  as default BACKGND_APP  --> PFASLEEP
2616             MOV @X+,&PFAWARM        ; INIT_TERM|INIT_SD     as default INI_HARD_APP --> PFAWARM
2617             MOV @X+,&TERM_VEC       ; TERMINAL_INT          as default vector       --> TERM_VEC
2618 ;-----------------------------------;
2619 ; INIT DP VOC_link                  ;
2620 ;-----------------------------------;
2621             MOV @X+,&RST_DP         ; ROMDICT           --> RST_DP
2622     .IFDEF VOCABULARY_SET
2623             MOV @X+,&RST_VOC        ; lastvoclink       --> RST_VOC
2624     .ENDIF
2625 ;-----------------------------------;
2626             JMP RST_STATE           ; then return to LIT|WARM from resp. QABORT|RESET
2627 ;-----------------------------------;
2628
2629 ;===============================================================================
2630 ; ┌┐ ┌─┐┬─┐  ┌─┐┌─┐┬─┐  ┌─┐┬ ┬┌─┐  ┌─┐┌─┐┬┬  ┬ ┬┬─┐┌─┐┌─┐  ┌─┐┌─┐┬  ┬    ┬ ┬┌─┐┬─┐┌─┐
2631 ; ├┴┐│ │├┬┘  ├─┘│ │├┬┘  ├─┘│ ││    ├┤ ├─┤││  │ │├┬┘├┤ └─┐  ├┤ ├─┤│  │    ├─┤├┤ ├┬┘├┤
2632 ; └─┘└─┘┴└─  ┴  └─┘┴└─  ┴  └─┘└─┘  └  ┴ ┴┴┴─┘└─┘┴└─└─┘└─┘  └  ┴ ┴┴─┘┴─┘  ┴ ┴└─┘┴└─└─┘
2633 ;===============================================================================
2634 RESET
2635 ;===============================================================================
2636 ; PUC 1: replace pin RESET by pin NMI, stops WDT_RESET
2637 ;-------------------------------------------------------------------------------
2638             BIS #3,&SFRRPCR         ; pin RST becomes pin NMI with falling edge, so SYSRSTIV = 4
2639             BIS #10h,&SFRIE1        ; enable NMI interrupt ==> hardware RESET is redirected to COLD.
2640             MOV #5A80h,&WDTCTL      ; disable WDT RESET
2641 ;-------------------------------------------------------------------------------
2642 ; PUC 2: INIT STACKS
2643 ;-------------------------------------------------------------------------------
2644             MOV #RSTACK,RSP         ; init return stack
2645             MOV #PSTACK,PSP         ; init parameter stack
2646 ;-------------------------------------------------------------------------------
2647 ; PUC 3: init RAM to 0
2648 ;-------------------------------------------------------------------------------
2649             MOV #RAM_LEN,X
2650 INITRAMLOOP SUB #2,X                ; 1
2651             MOV #0,RAM_ORG(X)       ; 3
2652             JNZ INITRAMLOOP         ; 2     6 cycles loop !
2653 ;-------------------------------------------------------------------------------
2654 ; PUC 4: I/O, RAM, RTC, CS, SYS initialisation limited to FastForth usage.
2655 ;          All unused I/O are set as input with pullup resistor.
2656 ;-------------------------------------------------------------------------------
2657             .include "TargetInit.asm"   ; include target specific init code
2658 ;-------------------------------------------------------------------------------
2659 ; PUC 5: GET SYSRSTIV
2660 ;-------------------------------------------------------------------------------
2661             MOV &RSTIV_MEM,TOS      ; get RSTIV_MEM = Soft_SYSRSTIV
2662             MOV #0,&RSTIV_MEM       ; clear RSTIV_MEM
2663             BIS &SYSRSTIV,TOS       ; hard_SYSRSTIV|soft_SYSRSTIV --> TOS; SYSRSTIV = 0
2664 ;-------------------------------------------------------------------------------
2665 ; PUC 6: START FORTH engine
2666 ;-------------------------------------------------------------------------------
2667             CALL #INI_FORTH         ; common ?ABORT|PUC "hybrid" subroutine with return to FORTH interpreter
2668             .word   WARM            ; goto WARM, without return. See forthMSP430FR_TERM_xxx.asm
2669 ;-----------------------------------;
2670
2671     .IFDEF MSP430ASSEMBLER
2672 ;===============================================================================
2673 ; ASSEMBLER OPTION
2674 ;===============================================================================
2675         .IFDEF EXTENDED_ASM
2676             .include "forthMSP430FR_EXTD_ASM.asm"
2677         .ELSE
2678             .include "forthMSP430FR_ASM.asm"
2679         .ENDIF
2680     .ENDIF
2681     .IFDEF UTILITY
2682 ;-------------------------------------------------------------------------------
2683 ; UTILITY WORDS OPTION
2684 ;-------------------------------------------------------------------------------
2685         .include "ADDON/UTILITY.asm"
2686     .ENDIF
2687     .IFDEF FIXPOINT
2688 ;-------------------------------------------------------------------------------
2689 ; FIXED POINT OPERATORS OPTION
2690 ;-------------------------------------------------------------------------------
2691         .include "ADDON/FIXPOINT.asm"
2692     .ENDIF
2693     .IFDEF SD_CARD_LOADER
2694 ;-------------------------------------------------------------------------------
2695 ; SD CARD OPTIONS
2696 ;-------------------------------------------------------------------------------
2697         .include "forthMSP430FR_SD_LowLvl.asm"  ; SD primitives
2698         .include "forthMSP430FR_SD_INIT.asm"    ; return to INIT_TERM; without use of IP,TOS
2699         .include "forthMSP430FR_SD_LOAD.asm"    ; SD LOAD driver
2700         .IFDEF SD_CARD_READ_WRITE
2701             .include "forthMSP430FR_SD_RW.asm"  ; SD Read/Write driver
2702         .ENDIF
2703         .IFDEF SD_TOOLS
2704             .include "ADDON/SD_TOOLS.asm"
2705         .ENDIF
2706     .ENDIF
2707 ;-------------------------------------------------------------------------------
2708 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against WIPE)
2709 ;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
2710 ;
2711 ;           .include "MY_CODE.asm"
2712 ;
2713 ;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2714 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against WIPE)
2715 ;-------------------------------------------------------------------------------
2716
2717 ;-------------------------------------------------------------------------------
2718 ; RESOLVE ASSEMBLY PTR, init interrupt Vectors
2719 ;-------------------------------------------------------------------------------
2720     .include "ThingsInLast.inc"