forthMSP430FR.asm

   1 ; -*- coding: utf-8 -*-
   2 ; http://patorjk.com/software/taag/#p=display&f=Banner&t=Fast Forth
   3
   4 ; Fast Forth For Texas Instrument MSP430FRxxxx FRAM devices
   5 ; Copyright (C) <2018>  <J.M. THOORENS>
   6 ;
   7 ; This program is free software: you can redistribute it and/or modify
   8 ; it under the terms of the GNU General Public License as published by
   9 ; the Free Software Foundation, either version 3 of the License, or
  10 ; (at your option) any later version.
  11 ;
  12 ; This program is distributed in the hope that it will be useful,
  13 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ; GNU General Public License for more details.
  16 ;
  17 ; You should have received a copy of the GNU General Public License
  18 ; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ; ----------------------------------------------------------------------
  21 ; compiled with MACROASSEMBLER AS (http://john.ccac.rwth-aachen.de:8000/as/)
  22 ; ----------------------------------------------------------------------
  23
  24 ;-------------------------------------------------------------------------------
  25 ; Vingt fois sur le métier remettez votre ouvrage,
  26 ; Polissez-le sans cesse, et le repolissez,
  27 ; Ajoutez quelquefois, et souvent effacez.
  28 ;                                                        Boileau, L'Art poétique
  29 ;-------------------------------------------------------------------------------
  30
  31 ;===============================================================================
  32 ;===============================================================================
  33 ; before assembling or programming you must set TARGET in param1 (SHIFT+F8)
  34 ; according to the selected TARGET below
  35 ;===============================================================================
  36 ;===============================================================================
  37
  38 VER .equ "V300" ; FORTH version
  39
  40     macexp off  ; uncomment to hide macro results in forthMSP430FR.lst
  41
  42 ;-------------------------------------------------------------------------------
  43 ; TARGETS kernel    ; sizes are for 8MHz, DTC=1, THREADS=1, 3WIRES (XON/XOFF)
  44 ;-------------------------------------------------------------------------------
  45 ;                                                                   ;INFO+VECTOR+ MAIN
  46 ;MSP_EXP430FR5739   ; compile for MSP-EXP430FR5739 launchpad        ; 24 +  2   + 3840 bytes
  47 ;MSP_EXP430FR5969   ; compile for MSP-EXP430FR5969 launchpad        ; 24 +  2   + 3816 bytes
  48 MSP_EXP430FR5994   ;; compile for MSP-EXP430FR5994 launchpad        ; 24 +  2   + 3842 bytes
  49 ;MSP_EXP430FR6989   ; compile for MSP-EXP430FR6989 launchpad        ; 24 +  2   + 3852 bytes
  50 ;MSP_EXP430FR4133   ; compile for MSP-EXP430FR4133 launchpad        ; 24 +  2   + 3906 bytes
  51 ;MSP_EXP430FR2355   ; compile for MSP-EXP430FR2355 launchpad        ; 24 +  2   + 3818 bytes
  52 ;MSP_EXP430FR2433   ; compile for MSP-EXP430FR2433 launchpad        ; 24 +  2   + 3804 bytes
  53 ;CHIPSTICK_FR2433   ; compile for the "CHIPSTICK" of M. Ken BOAK    ; 24 +  2   + 3804 bytes
  54
  55 ; choose DTC (Direct Threaded Code) model, if you don't know, choose 1
  56 DTC .equ 1  ; DTC model 1 : DOCOL = CALL rDOCOL           14 cycles 1 word      shortest DTC model
  57             ; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT   13 cycles 2 words     good compromize for mix FORTH/ASM code
  58             ; DTC model 3 : inlined DOCOL                  9 cycles 4 words     fastest
  59
  60 THREADS     .equ 16 ;  1,  2 ,  4 ,  8 ,  16,  32  search entries in dictionnary.
  61                     ; +0, +42, +54, +70, +104, +168 bytes, usefull to speed up compilation;
  62                     ; choose 16
  63
  64 FREQUENCY   .equ 16 ; fully tested at 0.25,0.5,1,2,4,8,16 MHz (+ 24 MHz for MSP430FR57xx,MSP430FR2355)
  65
  66 ;-------------------------------------------------------------------------------
  67 ; KERNEL OPTIONS that can't be added later
  68 ;-------------------------------------------------------------------------------
  69 CONDCOMP            ;; +  368 bytes : adds conditionnal compilation : COMPARE [DEFINED] [UNDEFINED] [IF] [ELSE] [THEN] MARKER
  70 MSP430ASSEMBLER     ;; + 1828 bytes : adds embedded assembler with TI syntax; without, you can do all but all much more slowly...
  71 EXTENDED_ASM        ;; + 1896 bytes : adds extended assembler for programming or data access beyond $FFFF.
  72 NONAME              ;; +   54 bytes : adds :NONAME CODENNM (CODENoNaMe)
  73 VOCABULARY_SET      ;; +  104 bytes : adds words: VOCABULARY FORTH ASSEMBLER ALSO PREVIOUS ONLY DEFINITIONS (FORTH83)
  74 DOUBLE_INPUT        ;; +   74 bytes : adds the interpretation input for double numbers (dot numbers)
  75 FIXPOINT_INPUT      ;; +  120 bytes : adds the interpretation input for Q15.16 numbers, mandatory for FIXPOINT ADD-ON
  76 SD_CARD_LOADER      ;; + 1748 bytes : to LOAD source files from SD_card
  77 SD_CARD_READ_WRITE  ;; + 1192 bytes : to read, create, write and del files + copy text files from PC to SD_Card
  78 BOOTLOADER          ;; +   72 bytes : includes to <reset> SD_CARD\BOOT.4TH as bootloader. To do: ' BOOT IS QUIT
  79 ;PROMPT              ; +   22 bytes : to display prompt "ok "
  80
  81 ;-------------------------------------------------------------------------------
  82 ; OPTIONAL ADDITIONS that can be added later by downloading their source file   >-----------------------+
  83 ; when added in kernel, they are protected against WIPE and Deep Reset...                               |
  84 ;-------------------------------------------------------------------------------                        v
  85 ;FIXPOINT            ; +  422/528 bytes add HOLDS F+ F- F/ F* F#S F. S>F 2@ 2CONSTANT               FIXPOINT.f
  86 ;UTILITY             ; +  434/524 bytes (1/16threads) : add .S .RS WORDS U.R DUMP ?                 UTILITY.f
  87 ;SD_TOOLS            ; +  142 bytes for trivial DIR, FAT, CLUSTER and SECTOR view, adds UTILITY     SD_TOOLS.f
  88 ;ANS_CORE_COMPLEMENT ; +  924 bytes : required to pass coretest.4th                                 ANS_COMP.f
  89
  90 ;-------------------------------------------------------------------------------
  91 ; FAST FORTH TERMINAL configuration
  92 ;-------------------------------------------------------------------------------
  93 ;HALFDUPLEX          ; to use FAST FORTH with half duplex terminal
  94 TERMINALBAUDRATE    .equ 115200 ; choose value considering the frequency and the UART2USB bridge, see explanations below.
  95 TERMINAL3WIRES      ;;               enable 3 wires (GND,TX,RX) with XON/XOFF software flow control (PL2303TA/HXD, CP2102)
  96 TERMINAL4WIRES      ;; + 12 bytes    enable 4 wires with hardware flow control on RX with RTS (PL2303TA/HXD, FT232RL)
  97 ;                                    this RTS pin may be permanently wired on SBWTCK/TEST pin without disturbing SBW 2 wires programming
  98 ;TERMINAL5WIRES      ; +  6 bytes    enable 5 wires with hardware flow control on RX/TX with RTS/CTS (PL2303TA/HXD, FT232RL)...
  99
 100 ;===============================================================================
 101 ; Software control flow XON/XOFF configuration:
 102 ;===============================================================================
 103 ; Launchpad --- UARTtoUSB device
 104 ;        RX <-- TX
 105 ;        TX --> RX
 106 ;       GND <-> GND
 107
 108 ; TERATERM config terminal      : NewLine receive : AUTO,
 109 ;                                 NewLine transmit : CR+LF
 110 ;                                 Size : 128 chars x 49 lines (adjust lines to your display)
 111
 112 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 113 ;                                 8 bits, no parity, 1 Stop bit,
 114 ;                                 XON/XOFF flow control,
 115 ;                                 delay = 0ms/line, 0ms/char
 116
 117 ; don't forget : save new TERATERM configuration !
 118
 119 ; --------------------------------------------------------------------------------------------
 120 ; Only two usb2uart bridges correctly handle XON / XOFF: cp2102 and pl2303.
 121 ; --------------------------------------------------------------------------------------------
 122 ; the best and cheapest: UARTtoUSB cable with Prolific PL2303HXD (or PL2303TA)
 123 ; works well in 3 WIRES (XON/XOFF) and 4WIRES (GND,RX,TX,RTS) config
 124 ; --------------------------------------------------------------------------------------------
 125 ;       PL2303TA 4 wires CABLE                         PL2303HXD 6 wires CABLE
 126 ; pads upside: 3V3,txd,rxd,gnd,5V               pads upside: gnd, 3V3,txd,rxd,5V
 127 ;    downside: cts,dcd,dsr,rts,dtr                 downside:     rts,cts
 128 ; --------------------------------------------------------------------------------------------
 129 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
 130 ; --------------------------------------------------------------------------------------------
 131 ; 9600,19200,38400,57600    (250kHz)
 132 ; + 115200,134400           (500kHz)
 133 ; + 201600,230400,268800    (1MHz)
 134 ; + 403200,460800,614400    (2MHz)
 135 ; + 806400,921600,1228800   (4MHz)
 136 ; + 2457600                 (8MHz,PL2303TA)
 137 ; + 1843200,2457600         (8MHz,PL2303HXD)
 138 ; + 3MBds                   (16MHz,PL2303TA)
 139 ; + 3MBds,4MBds,5MBds       (16MHz,PL2303HXD)
 140 ; + 6MBds                   (MSP430FR57xx,MSP430FR2355 families,24MHz)
 141
 142 ; UARTtoUSB module with Silabs CP2102 (supply current = 20 mA)
 143 ; ---------------------------------------------------------------------------------------------------
 144 ; WARNING ! if you use it as supply, buy a CP2102 module with a VCC switch 5V/3V3 and swith on 3V3 !
 145 ; ---------------------------------------------------------------------------------------------------
 146 ; 9600,19200,38400 (250kHz)
 147 ; + 57600 (500kHz)
 148 ; + 115200,134400,230400 (1MHz)
 149 ; + 460800 (2MHz)
 150 ; + 921600 (4MHz,8MHz,16MHz,24MHz)
 151
 152 ;===============================================================================
 153 ; Hardware control flow configuration: RTS is wired on UART2USB CTS pin
 154 ;===============================================================================
 155
 156 ; Launchpad <-> UARTtoUSB
 157 ;        RX <-- TX
 158 ;        TX --> RX
 159 ;       RTS --> CTS     (see launchpad.asm for RTS selected pin)
 160 ;       GND <-> GND
 161
 162 ; TERATERM config terminal      : NewLine receive : AUTO,
 163 ;                                 NewLine transmit : CR+LF
 164 ;                                 Size : 128 chars x 49 lines (adjust lines to your display)
 165
 166 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 167 ;                                 8bits, no parity, 1Stopbit,
 168 ;                                 Hardware flow control,
 169 ;                                 delay = 0ms/line, 0ms/char
 170
 171 ; don't forget : save new TERATERM configuration !
 172
 173 ; notice that the control flow seems not necessary for TX (CTS <-- RTS)
 174
 175 ; UARTtoUSB module with PL2303TA/HXD
 176 ; --------------------------------------------------------------------------------------------
 177 ; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad !
 178 ; --------------------------------------------------------------------------------------------
 179 ; 9600,19200,38400,57600    (250kHz)
 180 ; + 115200,134400           (500kHz)
 181 ; + 201600,230400,268800    (1MHz)
 182 ; + 403200,460800,614400    (2MHz)
 183 ; + 806400,921600,1228800   (4MHz)
 184 ; + 2457600,3000000         (8MHz)
 185 ; + 4000000,5000000         (16MHz)
 186 ; + 6000000                 (24MHz)
 187
 188 ; UARTtoUSB module with FTDI FT232RL (FT230X don't work correctly)
 189 ; ------------------------------------------------------------------------------
 190 ; WARNING ! buy a FT232RL module with a switch 5V/3V3 and select 3V3 !
 191 ; ------------------------------------------------------------------------------
 192 ; 9600,19200,38400,57600,115200 (500kHz)
 193 ; + 230400 (1MHz)
 194 ; + 460800 (2MHz)
 195 ; + 921600 (4,8,16 MHz)
 196
 197 ; ------------------------------------------------------------------------------
 198 ; UARTtoBluetooth 2.0 module (RN42 sparkfun bluesmirf) at 921600bds
 199 ; ------------------------------------------------------------------------------
 200 ; 9600,19200,38400,57600,115200 (500kHz)
 201 ; + 230400 (1MHz)
 202 ; + 460800 (2MHz)
 203 ; + 921600 (4,8,16 MHz)
 204
 205 ; RN42 config : connect RN41/RN42 module on teraterm, via USBtoUART bridge,
 206 ; -----------   8n1, 115200 bds, no flow control, echo on
 207 ;               $$$         // enter control mode, response: AOK
 208 ;               SU,92       // set 921600 bds, response: AOK
 209 ;               R,1         // reset module to take effect
 210 ;
 211 ;               connect RN42 module on FastForth target
 212 ;               add new bluetooth device on windows, password=1234
 213 ;               open the created output COMx port with TERATERM at 921600bds
 214
 215
 216 ; TERATERM config terminal      : NewLine receive : AUTO,
 217 ;                                 NewLine transmit : CR+LF
 218 ;                                 Size : 128 chars x 49 lines (adjust lines to your display)
 219
 220 ; TERATERM config serial port   : TERMINALBAUDRATE value,
 221 ;                                 8bits, no parity, 1Stopbit,
 222 ;                                 Hardware flow control or software flow control or ...no flow control!
 223 ;                                 delay = 0ms/line, 0ms/char
 224
 225 ; don't forget : save new TERATERM configuration !
 226
 227 ; in fact, compared to using a UART USB bridge, only the COMx port is to be updated.
 228 ; ------------------------------------------------------------------------------
 229
 230     .include "ThingsInFirst.inc" ; to define target config: I/O, memory, SFR, vectors, TERMINAL eUSCI, SD_Card eUSCI, LF_XTAL,
 231
 232 ;-------------------------------------------------------------------------------
 233 ; DTCforthMSP430FR5xxx RAM memory map:
 234 ;-------------------------------------------------------------------------------
 235
 236 ;-------------------------------------
 237 ; name              words   ; comment
 238 ;-------------------------------------
 239 ;LSTACK = L0 = LEAVEPTR     ; ----- RAM_ORG
 240                             ; |
 241 LSTACK_SIZE .equ    16      ; | grows up
 242                             ; V
 243                             ; ^
 244 PSTACK_SIZE .equ    48      ; | grows down
 245                             ; |
 246 ;PSTACK=S0                  ; ----- RAM_ORG + $80
 247                             ; ^
 248 RSTACK_SIZE .equ    48      ; | grows down
 249                             ; |
 250 ;RSTACK=R0                  ; ----- RAM_ORG + $E0
 251
 252 ;-------------------------------------
 253 ; names             bytes   ; comments
 254 ;-------------------------------------
 255 ; PAD_I2CADR                ; ----- RAM_ORG + $E0
 256 ; PAD_I2CCNT                ;
 257 ;PAD                        ; ----- RAM_ORG + $E4
 258                             ; |
 259 PAD_LEN     .equ    84      ; | grows up    (ans spec. : PAD >= 84 chars)
 260                             ; v
 261 ; TIB_I2CADR                ; ----- RAM_ORG + $138
 262 ; TIB_I2CCNT                ;
 263 ; TIB                       ; ----- RAM_ORG + $13C
 264                             ; |
 265 TIB_LEN     .equ    84      ; | grows up    (ans spec. : TIB >= 80 chars)
 266                             ; v
 267 ; HOLDS_ORG                 ; ------RAM_ORG + $190
 268                             ; ^
 269 HOLD_SIZE   .equ    34      ; | grows down  (ans spec. : HOLD_SIZE >= (2*n) + 2 char, with n = 16 bits/cell
 270                             ; |
 271 ; BASE_HOLD                 ; ----- RAM_ORG + $1B2
 272                             ;
 273                             ;       system variables
 274                             ;
 275                             ; ----- RAM_ORG + $1E0
 276                             ;
 277                             ;       assembler variables
 278                             ;
 279                             ; ----- RAM_ORG + $1F0
 280                             ;
 281                             ;       12 bytes free
 282                             ;
 283 ; SD_BUF_I2CADR             ; ----- RAM_ORG + $1FC
 284 ; SD_BUF_I2CCNT             ;
 285 ; SD_BUF                    ; ----- RAM_ORG + $200
 286                             ;
 287 SD_BUF_LEN   .equ 200h      ;       512 bytes buffer
 288                             ;
 289 ; SD_BUFEND                 ; ----- RAM_ORG + $400
 290
 291
 292 LSTACK          .equ RAM_ORG
 293 LEAVEPTR        .equ LSTACK             ; Leave-stack pointer
 294 PSTACK          .equ LSTACK+(LSTACK_SIZE*2)+(PSTACK_SIZE*2)
 295 RSTACK          .equ PSTACK+(RSTACK_SIZE*2)
 296 PAD_I2CADR      .equ PAD_ORG-4
 297 PAD_I2CCNT      .equ PAD_ORG-2
 298 PAD_ORG         .equ RSTACK+4
 299 TIB_I2CADR      .equ TIB_ORG-4
 300 TIB_I2CCNT      .equ TIB_ORG-2
 301 TIB_ORG         .equ PAD_ORG+PAD_LEN+4
 302 HOLDS_ORG       .equ TIB_ORG+TIB_LEN
 303
 304 BASE_HOLD       .equ HOLDS_ORG+HOLD_SIZE
 305
 306 ; ----------------------------------------------------
 307 ; RAM_ORG + $1B2 : RAM VARIABLES
 308 ; ----------------------------------------------------
 309 HP              .equ BASE_HOLD      ; HOLD ptr
 310 CAPS            .equ BASE_HOLD+2    ; CAPS ON = 32, CAPS OFF = 0
 311 LAST_NFA        .equ BASE_HOLD+4    ; NFA, VOC_PFA, CFA, PSP of last created word
 312 LAST_THREAD     .equ BASE_HOLD+6    ; used by QREVEAL
 313 LAST_CFA        .equ BASE_HOLD+8
 314 LAST_PSP        .equ BASE_HOLD+10
 315 STATE           .equ BASE_HOLD+12   ; Interpreter state
 316 SOURCE          .equ BASE_HOLD+14
 317 SOURCE_LEN      .equ BASE_HOLD+14
 318 SOURCE_ADR      .equ BASE_HOLD+16   ; len, addr of input stream
 319 TOIN            .equ BASE_HOLD+18   ; CurrentInputBuffer pointer
 320 DDP             .equ BASE_HOLD+20   ; dictionnary pointer
 321 LASTVOC         .equ BASE_HOLD+22   ; keep VOC-LINK
 322 CONTEXT         .equ BASE_HOLD+24   ; CONTEXT dictionnary space (8 CELLS)
 323 CURRENT         .equ BASE_HOLD+40   ; CURRENT dictionnary ptr
 324 BASE            .equ BASE_HOLD+42
 325 LINE            .equ BASE_HOLD+44   ; line in interpretation (initialized by NOECHO)
 326
 327 ; --------------------------------------------------------------;
 328 ; RAM_ORG + $1E0 : free for user after source file compilation  ;
 329 ; --------------------------------------------------------------;
 330 RAM_ASM         .equ BASE_HOLD+46
 331 ASMBW1          .equ BASE_HOLD+46
 332 ASMBW2          .equ BASE_HOLD+48
 333 ASMBW3          .equ BASE_HOLD+50
 334 ASMFW1          .equ BASE_HOLD+52
 335 ASMFW2          .equ BASE_HOLD+54
 336 ASMFW3          .equ BASE_HOLD+56
 337 SAV_CURRENT     .equ BASE_HOLD+58   ; save current CURRENT during create assembler words
 338 RPT_WORD        .equ BASE_HOLD+60   ; for extended assembler
 339 RAM_ASM_END     .equ BASE_HOLD+62   ;
 340 RAM_ASM_LEN     .equ RAM_ASM_END-RAM_ASM
 341 ; ----------------------------------;
 342 ; RAM_ORG + $1F0 : free for user    ;
 343 ; ----------------------------------;
 344
 345 ; --------------------------------------------------
 346 ; RAM_ORG + $1FC : RAM SD_CARD SD_BUF 4 + 512 bytes
 347 ; --------------------------------------------------
 348 SD_BUF_I2CADR   .equ SD_BUF-4
 349 SD_BUF_I2CCNT   .equ SD_BUF-2
 350 SD_BUF          .equ BASE_HOLD+78
 351 SD_BUFEND       .equ SD_BUF + 200h   ; 512bytes
 352
 353 ;-------------------------------------------------------------------------------
 354 ; INFO(DCBA) >= 256 bytes memory map (FRAM) :
 355 ;-------------------------------------------------------------------------------
 356
 357     .org    INFO_ORG
 358
 359 ; --------------------------
 360 ; FRAM INFO KERNEL CONSTANTS
 361 ; --------------------------
 362 INI_THREAD      .word THREADS               ; used by ADDON_UTILITY.f
 363 TERMBRW_RST     .word TERMBRW_INI           ; set by TERMINALBAUDRATE.inc
 364 TERMMCTLW_RST   .word TERMMCTLW_INI         ; set by TERMINALBAUDRATE.inc
 365     .IF FREQUENCY = 0.25
 366 FREQ_KHZ        .word 250                   ;
 367     .ELSEIF FREQUENCY = 0.5
 368 FREQ_KHZ        .word 500                   ;
 369     .ELSE
 370 FREQ_KHZ        .word FREQUENCY*1000        ; user use
 371     .ENDIF
 372 SAVE_SYSRSTIV   .word 0                     ;
 373 LPM_MODE        .word CPUOFF+GIE            ; LPM0 is the default mode
 374 ;LPM_MODE        .word CPUOFF+GIE+SCG0       ; LPM1 is the default mode (disable FLL)
 375 INIDP           .word ROMDICT               ; define RST_STATE
 376 INIVOC          .word lastvoclink           ; define RST_STATE
 377 FORTHVERSION    .word VERSIO                ;
 378 FORTHADDON      .word FADDON                ;
 379                 .word RXON                  ; 1814h for user use: CALL &RXON
 380                 .word RXOFF                 ; 1816h for user use: CALL &RXOFF
 381     .IFDEF SD_CARD_LOADER
 382                 .word ReadSectorWX          ; 1818h used by ADDON_SD_TOOLS.f
 383         .IFDEF SD_CARD_READ_WRITE
 384                 .word WriteSectorWX         ; 181Ah used by ADDON_SD_TOOLS.f
 385         .ENDIF ; SD_CARD_READ_WRITE
 386     .ENDIF ; SD_CARD_LOADER
 387
 388 ; -------------------------------
 389 ; VARIABLES that should be in RAM
 390 ; -------------------------------
 391
 392     .IFDEF SD_CARD_LOADER
 393         .IF RAM_LEN < 2048      ; if RAM < 2K (FR57xx) the variables below are in INFO space (FRAM)
 394 SD_ORG     .equ INFO_ORG+2Ch    ;
 395         .ELSE                   ; if RAM >= 2k the variables below are in RAM
 396 SD_ORG     .equ SD_BUFEND+2     ; 1 word guard
 397     .ENDIF
 398
 399     .org SD_ORG
 400
 401 ; ---------------------------------------
 402 ; FAT FileSystemInfos
 403 ; ---------------------------------------
 404 FATtype         .equ SD_ORG+0
 405 BS_FirstSectorL .equ SD_ORG+2  ; init by SD_Init, used by RW_Sector_CMD
 406 BS_FirstSectorH .equ SD_ORG+4  ; init by SD_Init, used by RW_Sector_CMD
 407 OrgFAT1         .equ SD_ORG+6  ; init by SD_Init,
 408 FATSize         .equ SD_ORG+8  ; init by SD_Init,
 409 OrgFAT2         .equ SD_ORG+10 ; init by SD_Init,
 410 OrgRootDIR      .equ SD_ORG+12 ; init by SD_Init, (FAT16 specific)
 411 OrgClusters     .equ SD_ORG+14 ; init by SD_Init, Sector of Cluster 0
 412 SecPerClus      .equ SD_ORG+16 ; init by SD_Init, byte size
 413
 414 SD_LOW_LEVEL    .equ SD_ORG+18
 415 ; ---------------------------------------
 416 ; SD command
 417 ; ---------------------------------------
 418 SD_CMD_FRM      .equ SD_LOW_LEVEL   ; SD_CMDx inverted frame ${CRC7,ll,LL,hh,HH,CMD}
 419 SectorL         .equ SD_LOW_LEVEL+6
 420 SectorH         .equ SD_LOW_LEVEL+8
 421
 422 ; ---------------------------------------
 423 ; SD_BUF management
 424 ; ---------------------------------------
 425 BufferPtr       .equ SD_LOW_LEVEL+10
 426 BufferLen       .equ SD_LOW_LEVEL+12
 427
 428 SD_FAT_LEVEL    .equ SD_LOW_LEVEL+14
 429 ; ---------------------------------------
 430 ; FAT entry
 431 ; ---------------------------------------
 432 ClusterL        .equ SD_FAT_LEVEL     ;
 433 ClusterH        .equ SD_FAT_LEVEL+2   ;
 434 NewClusterL     .equ SD_FAT_LEVEL+4   ;
 435 NewClusterH     .equ SD_FAT_LEVEL+6   ;
 436 CurFATsector    .equ SD_FAT_LEVEL+8   ; current FATSector of last free cluster
 437
 438 ; ---------------------------------------
 439 ; DIR entry
 440 ; ---------------------------------------
 441 DIRClusterL     .equ SD_FAT_LEVEL+10    ; contains the Cluster of current directory ; = 1 as FAT16 root directory
 442 DIRClusterH     .equ SD_FAT_LEVEL+12    ; contains the Cluster of current directory ; = 1 as FAT16 root directory
 443 EntryOfst       .equ SD_FAT_LEVEL+14
 444
 445 ; ---------------------------------------
 446 ; Handle Pointer
 447 ; ---------------------------------------
 448 CurrentHdl      .equ SD_FAT_LEVEL+16    ; contains the address of the last opened file structure, or 0
 449
 450 ; ---------------------------------------
 451 ; Load file operation
 452 ; ---------------------------------------
 453 pathname        .equ SD_FAT_LEVEL+18    ; start address
 454 EndOfPath       .equ SD_FAT_LEVEL+20    ; end address
 455
 456 ; ---------------------------------------
 457
 458 FirstHandle     .equ SD_FAT_LEVEL+22
 459 ; ---------------------------------------
 460 ; Handle structure
 461 ; ---------------------------------------
 462 ; three handle tokens :
 463 ; HDLB_Token= 0 : free handle
 464 ;           = 1 : file to read
 465 ;           = 2 : file updated (write)
 466 ;           =-1 : LOAD"ed file (source file)
 467
 468 ; offset values
 469 HDLW_PrevHDL    .equ 0  ; previous handle
 470 HDLB_Token      .equ 2  ; token
 471 HDLB_ClustOfst  .equ 3  ; Current sector offset in current cluster (Byte)
 472 HDLL_DIRsect    .equ 4  ; Dir SectorL
 473 HDLH_DIRsect    .equ 6  ; Dir SectorH
 474 HDLW_DIRofst    .equ 8  ; SD_BUF offset of Dir entry
 475 HDLL_FirstClus  .equ 10 ; File First ClusterLo (identify the file)
 476 HDLH_FirstClus  .equ 12 ; File First ClusterHi (identify the file)
 477 HDLL_CurClust   .equ 14 ; Current ClusterLo
 478 HDLH_CurClust   .equ 16 ; Current ClusterHi
 479 HDLL_CurSize    .equ 18 ; written size / not yet read size (Long)
 480 HDLH_CurSize    .equ 20 ; written size / not yet read size (Long)
 481 HDLW_BUFofst    .equ 22 ; SD_BUF offset ; used by LOAD"
 482 HDLW_PrevLEN    .equ 24 ; previous LEN
 483 HDLW_PrevORG    .equ 26 ; previous ORG
 484
 485     .IF RAM_LEN < 2048     ; due to the lack of RAM, only 5 handles and PAD replaces SDIB
 486
 487 HandleMax       .equ 5 ; and not 8 to respect INFO size (FRAM)
 488 HandleLenght    .equ 28
 489 HandleEnd       .equ FirstHandle+handleMax*HandleLenght
 490
 491 SD_END          .equ HandleEnd
 492
 493 SDIB_I2CADR     .equ PAD_ORG-4
 494 SDIB_I2CCNT     .equ PAD_ORG-2
 495 SDIB_ORG        .equ PAD_ORG
 496
 497     .ELSE      ; RAM_Size >= 2k all is in RAM
 498
 499 HandleMax       .equ 8
 500 HandleLenght    .equ 28
 501 HandleEnd       .equ FirstHandle+handleMax*HandleLenght
 502
 503 SDIB_I2CADR     .equ SDIB_ORG-4
 504 SDIB_I2CCNT     .equ SDIB_ORG-2
 505 SDIB_ORG        .equ HandleEnd+4
 506 SDIB_LEN        .equ 84             ; = TIB_LEN = PAD_LEN
 507
 508 SD_END          .equ SDIB_ORG+SDIB_LEN
 509
 510     .ENDIF ; RAM_Size
 511
 512 SD_LEN          .equ SD_END-SD_ORG
 513
 514     .ENDIF ; SD_CARD_LOADER
 515
 516 ;-------------------------------------------------------------------------------
 517 ; DTCforthMSP430FR5xxx program (FRAM) memory
 518 ;-------------------------------------------------------------------------------
 519
 520     .org    MAIN_ORG
 521
 522 ;-------------------------------------------------------------------------------
 523 ; DEFINING EXECUTIVE WORDS - DTC model
 524 ;-------------------------------------------------------------------------------
 525 ; very nice FAST FORTH added feature:
 526 ;-------------------------------------------------------------------------------
 527 ; as IP is always computed from the PC value, we can place low level to high level
 528 ; switches "COLON" or "LO2HI" anywhere in a word, i.e. not only at its beginning
 529 ; as ITC competitors.
 530 ;-------------------------------------------------------------------------------
 531
 532 RSP         .reg    R1      ; RSP = Return Stack Pointer (return stack)
 533
 534 ; DOxxx registers           ; must be saved before use and restored after use
 535 rDODOES     .reg    r4
 536 rDOCON      .reg    r5
 537 rDOVAR      .reg    r6
 538 rDOCOL      .reg    R7
 539
 540 R           .reg    r4      ; rDODOES alias
 541 Q           .reg    r5      ; rDOCON  alias
 542 P           .reg    r6      ; rDOVAR  alias
 543 M           .reg    R7      ; rDOCOL  alias
 544
 545 ; Scratch registers
 546 Y           .reg    R8
 547 X           .reg    R9
 548 W           .reg    R10
 549 T           .reg    R11
 550 S           .reg    R12
 551
 552 ; Forth virtual machine
 553 IP          .reg    R13      ; interpretative pointer
 554 TOS         .reg    R14      ; first PSP cell
 555 PSP         .reg    R15      ; PSP = Parameters Stack Pointer (stack data)
 556
 557
 558 mNEXT       .MACRO          ; return for low level words (written in assembler)
 559             MOV @IP+,PC     ; 4 fetch code address into PC, IP=PFA
 560             .ENDM           ; 4 cycles,1word = ITC -2cycles -1 word
 561
 562 NEXT        .equ    4D30h   ; 4 MOV @IP+,PC
 563
 564 FORTHtoASM  .MACRO          ; compiled by HI2LO
 565             .word   $+2     ; 0 cycle
 566             .ENDM           ; 0 cycle, 1 word
 567
 568 mSEMI       .MACRO
 569             MOV @RSP+,IP
 570             MOV @IP+,PC
 571             .ENDM
 572
 573 ;-------------------------------------------------------------------------------
 574 ; mDODOES  leave on parameter stack the PFA of a CREATE definition and execute Master word
 575 ;-------------------------------------------------------------------------------
 576
 577 mDODOES     .MACRO          ; compiled  by DOES>
 578             CALL rDODOES    ;    CALL xdodoes
 579             .ENDM           ; 1 word, 19 cycles (ITC-2)
 580
 581 DODOES      .equ    1284h   ; 4 CALL rDODOES ; [rDODOES] is defind as xdodoes by COLD
 582
 583 xdodoes   ; -- a-addr       ; 4 for CALL rDODOES
 584             SUB #2,PSP      ; 1
 585             MOV TOS,0(PSP)  ; 3 save TOS on parameters stack
 586             MOV @RSP+,TOS   ; 2 TOS = CFA address of master word, i.e. address of its first cell after DOES>
 587             PUSH IP         ; 3 save IP on return stack
 588             MOV @TOS+,IP    ; 2 IP = CFA of Master word, TOS = BODY address of created word
 589             MOV @IP+,PC     ; 4 Execute Master word
 590
 591 ;-------------------------------------------------------------------------------
 592 ; mDOCON  leave on parameter stack the [PFA] of a CONSTANT definition
 593 ;-------------------------------------------------------------------------------
 594
 595 mDOCON      .MACRO          ; compiled by CONSTANT
 596             CALL rDOCON     ; 1 word, 16 cycles (ITC+4)
 597             .ENDM           ;
 598
 599 DOCON       .equ    1285h   ; 4 CALL rDOCON ; [rDOCON] is defined as xdocon by COLD
 600
 601 xdocon  ;   -- constant     ; 4 for CALL rDOCON
 602             SUB #2,PSP      ; 1
 603             MOV TOS,0(PSP)  ; 3 save TOS on parameters stack
 604             MOV @RSP+,TOS   ; 2 TOS = CFA address of master word CONSTANT
 605             MOV @TOS,TOS    ; 2 TOS = CONSTANT value
 606             MOV @IP+,PC     ; 4 execute next word
 607                             ; 16 = ITC (+4)
 608
 609 ;-------------------------------------------------------------------------------
 610 ; mDOVAR leave on parameter stack the PFA of a VARIABLE definition
 611 ;-------------------------------------------------------------------------------
 612
 613 mDOVAR      .MACRO          ; compiled by VARIABLE
 614             CALL rDOVAR     ; 1 word, 14 cycles (ITC+4)
 615             .ENDM           ;
 616
 617 DOVAR       .equ    1286h   ; CALL rDOVAR ; [rDOVAR] is defined as xdovar by COLD
 618
 619 ;https://forth-standard.org/standard/core/Rfrom
 620 ;C R>    -- x    R: x --   pop from return stack ; CALL #RFROM performs DOVAR
 621             FORTHWORD "R>"
 622 xdovar
 623 RFROM       SUB #2,PSP          ; 1
 624             MOV TOS,0(PSP)      ; 3
 625             MOV @RSP+,TOS       ; 2
 626             mNEXT               ; 4
 627
 628
 629     .SWITCH DTC
 630 ;-------------------------------------------------------------------------------
 631     .CASE 1 ; DOCOL = CALL rDOCOL
 632 ;-------------------------------------------------------------------------------
 633
 634 xdocol      MOV @RSP+,W     ; 2
 635             PUSH IP         ; 3     save old IP on return stack
 636             MOV W,IP        ; 1     set new IP to PFA
 637             MOV @IP+,PC     ; 4     = NEXT
 638                             ; 10 cycles
 639
 640 ASMtoFORTH  .MACRO          ; compiled by LO2HI
 641             CALL #EXIT      ; 10 cycles
 642             .ENDM           ; 2 words, 10 cycles
 643
 644 mDOCOL      .MACRO          ; compiled by : and by colon
 645             CALL rDOCOL     ; 10 [rDOCOL] = xdocol
 646             .ENDM           ; 1 word, 14 cycles (CALL included) = ITC+4
 647
 648 DOCOL1      .equ    1287h   ; 4 CALL rDOCOL
 649
 650 ;-------------------------------------------------------------------------------
 651     .CASE 2 ; DOCOL = PUSH IP + CALL rDOCOL
 652 ;-------------------------------------------------------------------------------
 653
 654 ASMtoFORTH  .MACRO          ; compiled by LO2HI
 655             CALL rDOCOL     ; 10 [rDOCOL] = EXIT
 656             .ENDM           ; 1 word, 10 cycles
 657
 658 mDOCOL      .MACRO          ; compiled by : and by COLON
 659             PUSH IP         ; 3
 660             CALL rDOCOL     ; 10 [rDOCOL] = EXIT
 661             .ENDM           ; 2 words, 13 cycles = ITC+3
 662
 663 DOCOL1      .equ    120Dh   ; 3 PUSH IP
 664 DOCOL2      .equ    1287h   ; 4 CALL rDOCOL
 665
 666 ;-------------------------------------------------------------------------------
 667     .CASE 3 ; inlined DOCOL
 668 ;-------------------------------------------------------------------------------
 669
 670 ASMtoFORTH  .MACRO          ; compiled by LO2HI
 671             MOV PC,IP       ; 1
 672             ADD #4,IP       ; 1
 673             MOV @IP+,PC     ; 4 NEXT
 674             .ENDM           ; 6 cycles, 3 words
 675
 676 mDOCOL      .MACRO          ; compiled by : and by COLON
 677             PUSH IP         ; 3
 678             MOV PC,IP       ; 1
 679             ADD #4,IP       ; 1
 680             MOV @IP+,PC     ; 4 NEXT
 681             .ENDM           ; 4 words, 9 cycles (ITC-1)
 682
 683 DOCOL1      .equ    120Dh   ; 3 PUSH IP
 684 DOCOL2      .equ    400Dh   ; 1 MOV PC,IP
 685 DOCOL3      .equ    522Dh   ; 1 ADD #4,IP
 686
 687     .ENDCASE ; DTC
 688
 689 ;-------------------------------------------------------------------------------
 690 ; INTERPRETER LOGIC
 691 ;-------------------------------------------------------------------------------
 692
 693 ;https://forth-standard.org/standard/core/EXIT
 694 ;C EXIT     --      exit a colon definition; CALL #EXIT performs ASMtoFORTH (10 cycles)
 695 ;                                            JMP #EXIT performs EXIT
 696             FORTHWORD "EXIT"
 697 EXIT        MOV @RSP+,IP        ; 2 pop previous IP (or next PC) from return stack
 698             MOV @IP+,PC         ; 4 = NEXT
 699                                 ; 6 = ITC - 2
 700
 701 ;Z lit      -- x    fetch inline literal to stack
 702 ; This is the execution part of LITERAL.
 703             FORTHWORD "LIT"
 704 lit         SUB #2,PSP          ; 2  push old TOS..
 705             MOV TOS,0(PSP)      ; 3  ..onto stack
 706             MOV @IP+,TOS        ; 2  fetch new TOS value
 707             MOV @IP+,PC         ; 4  NEXT
 708                                 ; 11 = ITC - 2
 709
 710 ;-------------------------------------------------------------------------------
 711 ; STACK OPERATIONS
 712 ;-------------------------------------------------------------------------------
 713
 714 ;https://forth-standard.org/standard/core/DUP
 715 ;C DUP      x -- x x      duplicate top of stack
 716             FORTHWORD "DUP"
 717 DUP         SUB #2,PSP          ; 2  push old TOS..
 718             MOV TOS,0(PSP)      ; 3  ..onto stack
 719             mNEXT               ; 4
 720
 721 ;https://forth-standard.org/standard/core/qDUP
 722 ;C ?DUP     x -- 0 | x x    DUP if nonzero
 723             FORTHWORD "?DUP"
 724 QDUP        CMP #0,TOS          ; 2  test for TOS nonzero
 725             JNZ DUP             ; 2
 726             mNEXT               ; 4
 727
 728 ;https://forth-standard.org/standard/core/DROP
 729 ;C DROP     x --          drop top of stack
 730             FORTHWORD "DROP"
 731 DROP        MOV @PSP+,TOS       ; 2
 732             mNEXT               ; 4
 733
 734 ;https://forth-standard.org/standard/core/NIP
 735 ;C NIP      x1 x2 -- x2         Drop the first item below the top of stack
 736             FORTHWORD "NIP"
 737 NIP         ADD #2,PSP          ; 1
 738             mNEXT               ; 4
 739
 740 ;https://forth-standard.org/standard/core/SWAP
 741 ;C SWAP     x1 x2 -- x2 x1    swap top two items
 742             FORTHWORD "SWAP"
 743 SWAP        MOV @PSP,W          ; 2
 744             MOV TOS,0(PSP)      ; 3
 745             MOV W,TOS           ; 1
 746             mNEXT               ; 4
 747
 748 ;https://forth-standard.org/standard/core/OVER
 749 ;C OVER    x1 x2 -- x1 x2 x1
 750             FORTHWORD "OVER"
 751 OVER        MOV TOS,-2(PSP)     ; 3 -- x1 (x2) x2
 752             MOV @PSP,TOS        ; 2 -- x1 (x2) x1
 753             SUB #2,PSP          ; 1 -- x1 x2 x1
 754             mNEXT               ; 4
 755
 756 ;https://forth-standard.org/standard/core/ROT
 757 ;C ROT    x1 x2 x3 -- x2 x3 x1
 758             FORTHWORD "ROT"
 759 ROT         MOV @PSP,W          ; 2 fetch x2
 760             MOV TOS,0(PSP)      ; 3 store x3
 761             MOV 2(PSP),TOS      ; 3 fetch x1
 762             MOV W,2(PSP)        ; 3 store x2
 763             mNEXT               ; 4
 764
 765 ;https://forth-standard.org/standard/core/toR
 766 ;C >R    x --   R: -- x   push to return stack
 767             FORTHWORD ">R"
 768 TOR         PUSH TOS
 769             MOV @PSP+,TOS
 770             mNEXT
 771
 772 ; moved to rDOVAR
 773 ;;https://forth-standard.org/standard/core/Rfrom
 774 ;;C R>    -- x    R: x --   pop from return stack ; CALL #RFROM performs DOVAR
 775 ;            FORTHWORD "R>"
 776 ;RFROM       SUB #2,PSP          ; 1
 777 ;            MOV TOS,0(PSP)      ; 3
 778 ;            MOV @RSP+,TOS       ; 2
 779 ;            mNEXT               ; 4
 780
 781 ;https://forth-standard.org/standard/core/RFetch
 782 ;C R@    -- x     R: x -- x   fetch from rtn stk
 783             FORTHWORD "R@"
 784 RFETCH      SUB #2,PSP
 785             MOV TOS,0(PSP)
 786             MOV @RSP,TOS
 787             mNEXT
 788
 789 ;https://forth-standard.org/standard/core/DEPTH
 790 ;C DEPTH    -- +n        number of items on stack, must leave 0 if stack empty
 791             FORTHWORD "DEPTH"
 792 DEPTH       MOV TOS,-2(PSP)
 793             MOV #PSTACK,TOS
 794             SUB PSP,TOS       ; PSP-S0--> TOS
 795             RRA TOS           ; TOS/2   --> TOS
 796 DECPSP      SUB #2,PSP        ; post decrement stack...
 797             mNEXT
 798
 799 ;-------------------------------------------------------------------------------
 800 ; MEMORY OPERATIONS
 801 ;-------------------------------------------------------------------------------
 802
 803 ;https://forth-standard.org/standard/core/Fetch
 804 ;C @       a-addr -- x   fetch cell from memory
 805             FORTHWORD "@"
 806 FETCH       MOV @TOS,TOS
 807             mNEXT
 808
 809 ;https://forth-standard.org/standard/core/Store
 810 ;C !        x a-addr --   store cell in memory
 811             FORTHWORD "!"
 812 STORE       MOV @PSP+,0(TOS)    ;4
 813             MOV @PSP+,TOS       ;2
 814             mNEXT               ;4
 815
 816 ;https://forth-standard.org/standard/core/CFetch
 817 ;C C@     c-addr -- char   fetch char from memory
 818             FORTHWORD "C@"
 819 CFETCH      MOV.B @TOS,TOS      ;2
 820             mNEXT               ;4
 821
 822 ;https://forth-standard.org/standard/core/CStore
 823 ;C C!      char c-addr --    store char in memory
 824             FORTHWORD "C!"
 825 CSTORE      MOV.B @PSP+,0(TOS)  ;4
 826             ADD #1,PSP          ;1
 827             MOV @PSP+,TOS       ;2
 828             mNEXT
 829
 830 ;-------------------------------------------------------------------------------
 831 ; ARITHMETIC OPERATIONS
 832 ;-------------------------------------------------------------------------------
 833
 834 ;https://forth-standard.org/standard/core/Plus
 835 ;C +       n1/u1 n2/u2 -- n3/u3     add n1+n2
 836             FORTHWORD "+"
 837 PLUS        ADD @PSP+,TOS
 838             mNEXT
 839
 840 ;https://forth-standard.org/standard/core/Minus
 841 ;C -      n1/u1 n2/u2 -- n3/u3      n3 = n1-n2
 842             FORTHWORD "-"
 843 MINUS       SUB @PSP+,TOS   ;2  -- n2-n1
 844 NEGATE      XOR #-1,TOS     ;1
 845             ADD #1,TOS      ;1  -- n3 = -(n2-n1) = n1-n2
 846             mNEXT
 847
 848 ;https://forth-standard.org/standard/core/OnePlus
 849 ;C 1+      n1/u1 -- n2/u2       add 1 to TOS
 850             FORTHWORD "1+"
 851 ONEPLUS     ADD #1,TOS
 852             mNEXT
 853
 854 ;https://forth-standard.org/standard/core/OneMinus
 855 ;C 1-      n1/u1 -- n2/u2     subtract 1 from TOS
 856             FORTHWORD "1-"
 857 ONEMINUS    SUB #1,TOS
 858             mNEXT
 859
 860 ;https://forth-standard.org/standard/double/DABS
 861 ;C DABS     d1 -- |d1|     absolute value
 862             FORTHWORD "DABS"
 863 DABBS       AND #-1,TOS     ; clear V, set N
 864             JGE DABBSEND    ; if positive
 865 DNEGATE     XOR #-1,0(PSP)
 866             XOR #-1,TOS
 867             ADD #1,0(PSP)
 868             ADDC #0,TOS
 869 DABBSEND    mNEXT
 870
 871 ;-------------------------------------------------------------------------------
 872 ; COMPARAISON OPERATIONS
 873 ;-------------------------------------------------------------------------------
 874
 875 ;https://forth-standard.org/standard/core/ZeroEqual
 876 ;C 0=     n/u -- flag    return true if TOS=0
 877             FORTHWORD "0="
 878 ZEROEQUAL   SUB #1,TOS      ; borrow (clear cy) if TOS was 0
 879             SUBC TOS,TOS    ; TOS=-1 if borrow was set
 880             mNEXT
 881
 882 ;https://forth-standard.org/standard/core/Zeroless
 883 ;C 0<     n -- flag      true if TOS negative
 884             FORTHWORD "0<"
 885 ZEROLESS    ADD TOS,TOS     ;1 set carry if TOS negative
 886             SUBC TOS,TOS    ;1 TOS=-1 if carry was clear
 887             XOR #-1,TOS     ;1 TOS=-1 if carry was set
 888             mNEXT
 889
 890 ;https://forth-standard.org/standard/core/Equal
 891 ;C =      x1 x2 -- flag         test x1=x2
 892             FORTHWORD "="
 893 EQUAL       SUB @PSP+,TOS   ;2
 894             JZ TOSTRUE      ;2
 895 TOSFALSE    MOV #0,TOS      ;1
 896             mNEXT           ;4
 897
 898 ;https://forth-standard.org/standard/core/Uless
 899 ;C U<    u1 u2 -- flag       test u1<u2, unsigned
 900             FORTHWORD "U<"
 901 ULESS       MOV @PSP+,W     ;2
 902             SUB TOS,W       ;1 u1-u2 in W, carry clear if borrow
 903             JC TOSFALSE     ;  unsigned
 904 TOSTRUE     MOV #-1,TOS     ;1
 905             mNEXT           ;4
 906
 907 ;https://forth-standard.org/standard/core/less
 908 ;C <      n1 n2 -- flag        test n1<n2, signed
 909             FORTHWORD "<"
 910 LESS        MOV @PSP+,W     ;2 W=n1
 911             SUB TOS,W       ;1 W=n1-n2 flags set
 912             JL TOSTRUE      ;2 signed
 913             JGE TOSFALSE    ;2 --> +5
 914
 915 ;https://forth-standard.org/standard/core/more
 916 ;C >     n1 n2 -- flag         test n1>n2, signed
 917             FORTHWORD ">"
 918 GREATER     SUB @PSP+,TOS   ;2 TOS=n2-n1
 919             JL TOSTRUE      ;2 signed
 920             JGE TOSFALSE    ;2 --> +5
 921
 922 ;-------------------------------------------------------------------------------
 923 ; SYSTEM  CONSTANTS
 924 ;-------------------------------------------------------------------------------
 925
 926 ;https://forth-standard.org/standard/core/BL
 927 ;C BL      -- char            an ASCII space
 928             FORTHWORD "BL"
 929 FBLANK       mDOCON
 930             .word   32
 931
 932 ;-------------------------------------------------------------------------------
 933 ; SYSTEM VARIABLES
 934 ;-------------------------------------------------------------------------------
 935
 936 ;https://forth-standard.org/standard/core/BASE
 937 ;C BASE    -- a-addr       holds conversion radix
 938             FORTHWORD "BASE"
 939 FBASE       mDOCON
 940             .word   BASE    ; VARIABLE address in RAM space
 941
 942 ;https://forth-standard.org/standard/core/STATE
 943 ;C STATE   -- a-addr       holds compiler state
 944             FORTHWORD "STATE"
 945 FSTATE      mDOCON
 946             .word   STATE   ; VARIABLE address in RAM space
 947
 948 ;-------------------------------------------------------------------------------
 949 ; ANS complement OPTION
 950 ;-------------------------------------------------------------------------------
 951     .IFDEF ANS_CORE_COMPLEMENT
 952     .include "ADDON/ANS_COMPLEMENT.asm"
 953     .ENDIF ; ANS_COMPLEMENT
 954
 955 ;-------------------------------------------------------------------------------
 956 ; NUMERIC OUTPUT
 957 ;-------------------------------------------------------------------------------
 958
 959 ; Numeric conversion is done last digit first, so
 960 ; the output buffer is built backwards in memory.
 961
 962 ;https://forth-standard.org/standard/core/num-start
 963 ;C <#    --       begin numeric conversion (initialize Hold Pointer)
 964             FORTHWORD "<#"
 965 LESSNUM     MOV #BASE_HOLD,&HP
 966             mNEXT
 967
 968 ;https://forth-standard.org/standard/core/UMDivMOD
 969 ; UM/MOD   udlo|udhi u1 -- r q   unsigned 32/16->r16 q16
 970             FORTHWORD "UM/MOD"
 971 UMSLASHMOD  PUSH #DROP          ;3 as return address for MU/MOD
 972
 973 ; unsigned 32-BIT DiViDend : 16-BIT DIVisor --> 32-BIT QUOTient, 16-BIT REMainder
 974 ; 2 times faster if DVDhi = 0 (it's the general case)
 975
 976 ; reg     division        MU/MOD      NUM
 977 ; -----------------------------------------
 978 ; S     = DVDlo (15-0)  = ud1lo     = ud1lo
 979 ; TOS   = DVDhi (31-16) = ud1hi     = ud1hi
 980 ; T     = DIVlo         = BASE
 981 ; W     = REMlo         = REMlo     = digit --> char --> -[HP]
 982 ; X     = QUOTlo        = ud2lo     = ud2lo
 983 ; Y     = QUOThi        = ud2hi     = ud2hi
 984 ; rDODOES = count
 985
 986 ; MU/MOD        DVDlo DVDhi DIVlo -- REMlo QUOTlo QUOThi, also used by fixpoint and #
 987 MUSMOD      MOV TOS,T           ;1 T = DIV
 988             MOV 2(PSP),S        ;3 S = DVDlo
 989             MOV @PSP,TOS        ;2 TOS = DVDhi
 990 MUSMOD1     MOV #0,W            ;1  W = REMlo = 0
 991 MUSMOD2     MOV #32,rDODOES     ;2  init loop count
 992 ; -----------------------------------------
 993             CMP #0,TOS          ;1  DVDhi=0 ?
 994             JNZ MDIV1           ;2  no
 995             RRA rDODOES         ;1  yes:loop count / 2
 996             MOV S,TOS           ;1      DVDhi <-- DVDlo
 997             MOV #0,S            ;1      DVDlo <-- 0
 998             MOV #0,X            ;1      QUOTlo <-- 0 (to do QUOThi = 0 at the end of division)
 999 ; -----------------------------------------
1000 MDIV1       CMP T,W             ;1  REMlo U>= DIV ?
1001             JNC MDIV2           ;2  no : carry is reset
1002             SUB T,W             ;1  yes: REMlo - DIV ; carry is set after soustraction!
1003 MDIV2       ADDC X,X            ;1  RLC quotLO
1004             ADDC Y,Y            ;1  RLC quotHI
1005             SUB #1,rDODOES      ;1  Decrement loop counter
1006             JN ENDMDIV          ;2
1007             ADD S,S             ;1  RLA DVDlo
1008             ADDC TOS,TOS        ;1  RLC DVDhi
1009             ADDC W,W            ;1  RLC REMlo
1010             JNC MDIV1           ;2
1011             SUB T,W             ;1  REMlo - DIV
1012             BIS #1,SR           ;1  SETC
1013             JMP MDIV2           ;2
1014 ENDMDIV     MOV #xdodoes,rDODOES;2  restore rDODOES
1015             MOV W,2(PSP)        ;3  REMlo in 2(PSP)
1016             MOV X,0(PSP)        ;3  QUOTlo in 0(PSP)
1017             MOV Y,TOS           ;1  QUOThi in TOS
1018             RET                 ;4  35 words, about 473 cycles, not FORTH executable !
1019
1020 ;https://forth-standard.org/standard/core/num
1021 ;C #     ud1lo ud1hi -- ud2lo ud2hi          convert 1 digit of output
1022             FORTHWORD "#"
1023 NUM         MOV &BASE,T         ;3                      T = Divisor
1024 NUM1        MOV @PSP,S          ;2 -- DVDlo DVDhi       S = DVDlo
1025             SUB #2,PSP          ;1 -- DVDlo x DVDhi     TOS = DVDhi
1026             CALL #MUSMOD1       ;4 -- REMlo QUOTlo QUOThi
1027             MOV @PSP+,0(PSP)    ;4 -- QUOTlo QUOThi
1028 TODIGIT     CMP.B #10,W         ;2  W = REMlo
1029             JLO TODIGIT1        ;2  U<
1030             ADD.B #7,W          ;2
1031 TODIGIT1    ADD.B #30h,W        ;2
1032 HOLDW       SUB #1,&HP          ;4  store W=char --> -[HP]
1033             MOV &HP,Y           ;3
1034             MOV.B W,0(Y)        ;3
1035             mNEXT               ;4  26 words
1036
1037 ;https://forth-standard.org/standard/core/numS
1038 ;C #S    udlo:udhi -- udlo:udhi=0       convert remaining digits
1039             FORTHWORD "#S"
1040 NUMS        mDOCOL
1041             .word   NUM         ;       X=QUOTlo
1042             FORTHtoASM          ;
1043             SUB #2,IP           ;1      restore NUM return
1044             CMP #0,X            ;1      test ud2lo first (generally false)
1045             JNZ NUM1            ;2
1046             CMP #0,TOS          ;1      then test ud2hi (generally true)
1047             JNZ NUM1            ;2
1048             mSEMI               ;6 10 words, about 241/417 cycles/char
1049
1050 ;https://forth-standard.org/standard/core/num-end
1051 ;C #>    udlo:udhi -- c-addr u    end conversion, get string
1052             FORTHWORD "#>"
1053 NUMGREATER  MOV &HP,0(PSP)
1054             MOV #BASE_HOLD,TOS
1055             SUB @PSP,TOS
1056             mNEXT
1057
1058 ;https://forth-standard.org/standard/core/HOLD
1059 ;C HOLD  char --        add char to output string
1060             FORTHWORD "HOLD"
1061 HOLD        MOV TOS,W           ;1
1062             MOV @PSP+,TOS       ;2
1063             JMP HOLDW           ;15
1064
1065 ;https://forth-standard.org/standard/core/SIGN
1066 ;C SIGN  n --           add minus sign if n<0
1067             FORTHWORD "SIGN"
1068 SIGN        CMP #0,TOS
1069             MOV @PSP+,TOS
1070             MOV #'-',W
1071             JN HOLDW        ; 0<
1072             mNEXT
1073
1074 ;https://forth-standard.org/standard/double/Dd
1075 ;C D.     dlo dhi --           display d (signed)
1076             FORTHWORD "D."
1077 DDOT         mDOCOL
1078             .word   LESSNUM,DUP,TOR,DABBS,NUMS
1079             .word   RFROM,SIGN,NUMGREATER,TYPE,SPACE,EXIT
1080
1081 ;https://forth-standard.org/standard/core/Ud
1082 ;C U.    u --           display u (unsigned)
1083             FORTHWORD "U."
1084 UDOT        MOV #0,Y
1085 UDOT1       SUB #2,PSP      ; convert n|u to d|ud
1086             MOV TOS,0(PSP)
1087             MOV Y,TOS
1088             JMP DDOT
1089
1090 ;https://forth-standard.org/standard/core/d
1091 ;C .     n --           display n (signed)
1092             FORTHWORD "."
1093 DOT         CMP #0,TOS
1094             JGE UDOT
1095             MOV #-1,Y
1096             JMP UDOT1
1097
1098 ;-------------------------------------------------------------------------------
1099 ; DICTIONARY MANAGEMENT
1100 ;-------------------------------------------------------------------------------
1101
1102 ;https://forth-standard.org/standard/core/HERE
1103 ;C HERE    -- addr      returns memory ptr
1104             FORTHWORD "HERE"
1105 HERE        SUB #2,PSP
1106             MOV TOS,0(PSP)
1107             MOV &DDP,TOS
1108             mNEXT
1109
1110 ;https://forth-standard.org/standard/core/ALLOT
1111 ;C ALLOT   n --         allocate n bytes
1112             FORTHWORD "ALLOT"
1113 ALLOT       ADD TOS,&DDP
1114             MOV @PSP+,TOS
1115             mNEXT
1116
1117 ;https://forth-standard.org/standard/core/CComma
1118 ;C C,   char --        append char
1119             FORTHWORD "C,"
1120 CCOMMA      MOV &DDP,W
1121             MOV.B TOS,0(W)
1122             ADD #1,&DDP
1123             MOV @PSP+,TOS
1124             mNEXT
1125
1126 ;-------------------------------------------------------------------------------
1127 ; BRANCH and LOOP OPERATORS
1128 ;-------------------------------------------------------------------------------
1129
1130 ;Z branch   --                  branch always
1131 BRAN        MOV @IP,IP      ; 2
1132             mNEXT           ; 4
1133
1134 ;Z ?FalseBranch   x --      ; branch if TOS is FALSE (=zero)
1135 QFBRAN      CMP #0,TOS      ; 1  test TOS value
1136             MOV @PSP+,TOS   ; 2  pop new TOS value (doesn't change flags)
1137             JZ BRAN         ; 2  if TOS was = 0, take the branch = 11 cycles
1138             ADD #2,IP       ; 1  else skip the branch destination
1139             mNEXT           ; 4  ==> branch not taken = 10 cycles
1140
1141 ;Z ?TrueBranch   x --       ; branch if TOS is true (<> zero)
1142 QTBRAN      CMP #0,TOS      ; 1  test TOS value
1143             MOV @PSP+,TOS   ; 2  pop new TOS value (doesn't change flags)
1144             JNZ BRAN        ; 2  if TOS was <> 0, take the branch = 11 cycles
1145             ADD #2,IP       ; 1  else skip the branch destination
1146             mNEXT           ; 4  ==> branch not taken = 10 cycles
1147
1148 ;Z (do)    n1|u1 n2|u2 --  R: -- sys1 sys2      run-time code for DO
1149 ;                                               n1|u1=limit, n2|u2=index
1150 xdo         MOV #8000h,X    ;2 compute 8000h-limit "fudge factor"
1151             SUB @PSP+,X     ;2
1152             MOV TOS,Y       ;1 loop ctr = index+fudge
1153             MOV @PSP+,TOS   ;2 pop new TOS
1154             ADD X,Y         ;1
1155             PUSHM #2,X      ;4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX
1156             mNEXT           ;4
1157
1158 ;Z (+loop)   n --   R: sys1 sys2 --  | sys1 sys2
1159 ;                        run-time code for +LOOP
1160 ; Add n to the loop index.  If loop terminates, clean up the
1161 ; return stack and skip the branch. Else take the inline branch.
1162 xploop      ADD TOS,0(RSP)  ;4 increment INDEX by TOS value
1163             MOV @PSP+,TOS   ;2 get new TOS, doesn't change flags
1164 xloopnext   BIT #100h,SR    ;2 is overflow bit set?
1165             JZ BRAN         ;2 no overflow = loop
1166             ADD #2,IP       ;1 overflow = loop done, skip branch ofs
1167 UNXLOOP     ADD #4,RSP      ;1 empty RSP
1168             mNEXT           ;4 16~ taken or not taken xloop/loop
1169
1170
1171 ;Z (loop)   R: sys1 sys2 --  | sys1 sys2
1172 ;                        run-time code for LOOP
1173 ; Add 1 to the loop index.  If loop terminates, clean up the
1174 ; return stack and skip the branch.  Else take the inline branch.
1175 ; Note that LOOP terminates when index=8000h.
1176 xloop       ADD #1,0(RSP)   ;4 increment INDEX
1177             JMP xloopnext   ;2
1178
1179 ;https://forth-standard.org/standard/core/UNLOOP
1180 ;C UNLOOP   --   R: sys1 sys2 --  drop loop parms
1181             FORTHWORD "UNLOOP"
1182 UNLOOP      JMP UNXLOOP
1183
1184 ;https://forth-standard.org/standard/core/I
1185 ;C I        -- n   R: sys1 sys2 -- sys1 sys2
1186 ;C                  get the innermost loop index
1187             FORTHWORD "I"
1188 II          SUB #2,PSP      ;1 make room in TOS
1189             MOV TOS,0(PSP)  ;3
1190             MOV @RSP,TOS    ;2 index = loopctr - fudge
1191             SUB 2(RSP),TOS  ;3
1192             mNEXT           ;4 13~
1193
1194 ;https://forth-standard.org/standard/core/J
1195 ;C J        -- n   R: 4*sys -- 4*sys
1196 ;C                  get the second loop index
1197             FORTHWORD "J"
1198 JJ          SUB #2,PSP      ; make room in TOS
1199             MOV TOS,0(PSP)
1200             MOV 4(RSP),TOS  ; index = loopctr - fudge
1201             SUB 6(RSP),TOS
1202             mNEXT
1203
1204 ; ------------------------------------------------------------------------------
1205 ; TERMINAL I/O, input part
1206 ; ------------------------------------------------------------------------------
1207
1208 ;https://forth-standard.org/standard/core/KEY
1209 ;C KEY      -- c      wait character from input device ; primary DEFERred word
1210             FORTHWORD "KEY"
1211 KEY         MOV @PC+,PC             ;3 Code Field Address (CFA) of KEY
1212 PFAKEY      .word   BODYKEY         ;  Parameter Field Address (PFA) of KEY, with default value
1213 BODYKEY     MOV &TERM_RXBUF,Y       ; empty buffer
1214             SUB #2,PSP              ; 1  push old TOS..
1215             MOV TOS,0(PSP)          ; 3  ..onto stack
1216             CALL #RXON
1217 KEYLOOP     BIT #UCRXIFG,&TERM_IFG  ; loop if bit0 = 0 in interupt flag register
1218             JZ KEYLOOP              ;
1219             MOV &TERM_RXBUF,TOS     ;
1220             CALL #RXOFF             ;
1221             mNEXT
1222
1223 ;-------------------------------------------------------------------------------
1224 ; INTERPRETER INPUT, the kernel of kernel !
1225 ;-------------------------------------------------------------------------------
1226
1227     .IFDEF SD_CARD_LOADER
1228     .include "forthMSP430FR_SD_ACCEPT.asm"
1229     .ENDIF
1230
1231     .IFDEF DEFER_ACCEPT
1232
1233 ;https://forth-standard.org/standard/core/ACCEPT
1234 ;C ACCEPT  addr addr len -- addr len'  get line at addr to interpret len' chars
1235             FORTHWORD "ACCEPT"
1236 ACCEPT      MOV @PC+,PC             ;3 Code Field Address (CFA) of ACCEPT
1237 PFAACCEPT   .word   BODYACCEPT      ;  Parameter Field Address (PFA) of ACCEPT
1238 BODYACCEPT                          ;  BODY of ACCEPT = default execution of ACCEPT
1239
1240     .ELSE
1241
1242 ;https://forth-standard.org/standard/core/ACCEPT
1243 ;C ACCEPT  addr addr len -- addr len'  get line at addr to interpret len' chars
1244             FORTHWORD "ACCEPT"
1245 ACCEPT
1246
1247     .ENDIF
1248
1249     .IFDEF  HALFDUPLEX  ; to use FAST FORTH with half duplex input terminal (bluetooth or wifi connexion)
1250
1251     .include "forthMSP430FR_HALFDUPLEX.asm"
1252
1253     .ELSE   ; to use FAST FORTH with full duplex terminal (USBtoUART bridge)
1254
1255 ; con speed of TERMINAL link, there are three bottlenecks :
1256 ; 1- time to send XOFF/RTS_high on CR (CR+LF=EOL), first emergency.
1257 ; 2- the char loop time,
1258 ; 3- the time between sending XON/RTS_low and clearing UCRXIFG on first received char,
1259 ; everything must be done to reduce these times, taking into account the necessity of switching to SLEEP (LPMx mode).
1260 ; ----------------------------------;
1261 ; ACCEPT part I prepare TERMINAL_INT;
1262 ; ----------------------------------;
1263             MOV #ENDACCEPT,S        ;2              S = XOFF_ret
1264             MOV #AKEYREAD1,T        ;2              T = XON_ret
1265             PUSHM #3,IP             ;5              PUSHM IP,S,T       r-- ACCEPT_ret XOFF_ret XON_ret
1266             MOV TOS,W               ;1 -- addr len
1267             MOV @PSP,TOS            ;2 -- org ptr                                             )
1268             ADD TOS,W               ;1 -- org ptr   W=Bound                                   )
1269             MOV #0Dh,T              ;2              T = 'CR' to speed up char loop in part II  > prepare stack and registers for TERMINAL_INT use
1270             MOV #20h,S              ;2              S = 'BL' to speed up char loop in part II )
1271             MOV #AYEMIT_RET,IP      ;2              IP = return for YEMIT                     )
1272             BIT #UCRXIFG,&TERM_IFG  ;3              RX_Int ?
1273             JZ ACCEPTNEXT           ;2              no : case of quiet input terminal
1274             MOV &TERM_RXBUF,Y       ;3              yes: clear RX_Int
1275             CMP #0Ah,Y              ;2                   received char = LF ? (end of downloading ?)
1276             JNZ RXON                ;2                   no : send XON then RET to AKEYREAD1 to process first char of new line.
1277 ACCEPTNEXT  ADD #2,RSP              ;1              replace XON_ret = AKEYREAD1 by XON_ret = SLEEP
1278             MOV #SLEEP,X            ;2
1279             PUSHM #5,IP             ;7              r-- ACCEPT_ret XOFF_ret YEMIT_ret 'BL' 'CR' bound XON_ret
1280 ; ----------------------------------;
1281
1282 ; ----------------------------------;
1283 RXON                                ;
1284 ; ----------------------------------;
1285     .IFDEF TERMINAL3WIRES           ;
1286 RXON_LOOP   BIT #UCTXIFG,&TERM_IFG  ;3  wait the sending of last char, useless at high baudrates
1287             JZ RXON_LOOP            ;2
1288             MOV #17,&TERM_TXBUF     ;4  move char XON into TX_buf
1289     .ENDIF                          ;
1290     .IFDEF TERMINAL4WIRES           ;
1291             BIC.B #RTS,&HANDSHAKOUT ;4  set RTS low
1292     .ENDIF                          ;
1293 ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;
1294 ; starts first and 3th stopwatches  ;
1295 ; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;
1296             RET                     ;4  to BACKGND (End of file download or quiet input) or AKEYREAD1 (get next line of file downloading)
1297 ; ----------------------------------;   ...or user defined
1298
1299 ; ----------------------------------;
1300 RXOFF                               ;
1301 ; ----------------------------------;
1302     .IFDEF TERMINAL3WIRES           ;
1303             MOV #19,&TERM_TXBUF     ;4 move XOFF char into TX_buf
1304     .ENDIF                          ;
1305     .IFDEF TERMINAL4WIRES           ;
1306             BIS.B #RTS,&HANDSHAKOUT ;4 set RTS high
1307     .ENDIF                          ;
1308             RET                     ;4 to ENDACCEPT, ...or user defined
1309 ; ----------------------------------;
1310
1311 ; ----------------------------------;
1312     ASMWORD "SLEEP"                 ;   may be redirected
1313 SLEEP       MOV @PC+,PC             ;3  Code Field Address (CFA) of SLEEP
1314 PFASLEEP    .word   BODYSLEEP       ;   Parameter Field Address (PFA) of SLEEP, with default value
1315 BODYSLEEP
1316             BIS &LPM_MODE,SR        ;3  enter in LPMx sleep mode with GIE=1
1317 ; ----------------------------------;   default FAST FORTH mode (for its input terminal use) : LPM0.
1318
1319 ;###############################################################################################################
1320 ;###############################################################################################################
1321
1322 ; ### #     # ####### ####### ######  ######  #     # ######  #######  #####     #     # ####### ######  #######
1323 ;  #  ##    #    #    #       #     # #     # #     # #     #    #    #     #    #     # #       #     # #
1324 ;  #  # #   #    #    #       #     # #     # #     # #     #    #    #          #     # #       #     # #
1325 ;  #  #  #  #    #    #####   ######  ######  #     # ######     #     #####     ####### #####   ######  #####
1326 ;  #  #   # #    #    #       #   #   #   #   #     # #          #          #    #     # #       #   #   #
1327 ;  #  #    ##    #    #       #    #  #    #  #     # #          #    #     #    #     # #       #    #  #
1328 ; ### #     #    #    ####### #     # #     #  #####  #          #     #####     #     # ####### #     # #######
1329
1330 ;###############################################################################################################
1331 ;###############################################################################################################
1332
1333
1334 ; here, Fast FORTH sleeps, waiting any interrupt.
1335 ; IP,S,T,W,X,Y registers (R13 to R8) are free for any interrupt routine...
1336 ; ...and so PSP and RSP stacks with their rules of use.
1337 ; remember: in any interrupt routine you must include : BIC #0x78,0(RSP) before RETI
1338 ;           to force return to SLEEP.
1339 ;           or (bad idea ? previous SR flags are lost) simply : ADD #2 RSP, then RET instead of RETI
1340
1341
1342 ; ==================================;
1343             JMP SLEEP               ;2  here is the return for any interrupts, else TERMINAL_INT  :-)
1344 ; ==================================;
1345
1346 ; **********************************;
1347 TERMINAL_INT                        ; <--- TEMR RX interrupt vector, delayed by the LPMx wake up time
1348 ; **********************************;      if wake up time increases, max bauds rate decreases...
1349 ; (ACCEPT) part II under interrupt  ; Org Ptr --
1350 ; ----------------------------------;
1351             ADD #4,RSP              ;1  remove SR and PC from stack, SR flags are lost (unused by FORTH interpreter)
1352             POPM #4,IP              ;6  POPM W=buffer_bound, T=0Dh, S=20h, IP=AYEMIT_RET       r-- ACCEPT_ret XOFF_ret
1353 ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;
1354 ; starts the 2th stopwatch          ;
1355 ; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;
1356 AKEYREAD    MOV.B &TERM_RXBUF,Y     ;3  read character into Y, UCRXIFG is cleared
1357 ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;
1358 ; stops the 3th stopwatch           ; 3th bottleneck result : 17~ + LPMx wake_up time ( + 5~ XON loop if F/Bds<230400 )
1359 ; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;
1360 AKEYREAD1   CMP.B S,Y               ;1      printable char ?
1361             JHS ASTORETEST          ;2      yes
1362             CMP.B T,Y               ;1      CR ?
1363             JZ RXOFF                ;2      then RET to ENDACCEPT
1364 ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;+ 4    to send RXOFF
1365 ; stops the first stopwatch         ;=      first bottleneck, best case result: 27~ + LPMx wake_up time..
1366 ; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;       ...or 14~ in case of empty line
1367             CMP.B #8,Y              ;1      char = BS ?
1368             JNE WAITaKEY            ;2      case of other control chars
1369 ; ----------------------------------;
1370 ; start of backspace                ;       made only by an human
1371 ; ----------------------------------;
1372             CMP @PSP,TOS            ;       Ptr = Org ?
1373             JZ WAITaKEY             ;       yes: do nothing
1374             SUB #1,TOS              ;       no : dec Ptr
1375             JMP YEMIT1              ;       send BS
1376 ; ----------------------------------;
1377 ; end of backspace                  ;
1378 ; ----------------------------------;
1379 ASTORETEST  CMP W,TOS               ; 1 Bound is reached ?
1380             JZ YEMIT1               ; 2 yes: send echo then loopback
1381             MOV.B Y,0(TOS)          ; 3 no: store char @ Ptr, send echo then loopback
1382             ADD #1,TOS              ; 1     increment Ptr
1383 YEMIT1                              ;
1384             BIT #UCTXIFG,&TERM_IFG  ; 3 wait the sending end of previous char, useless at high baudrates
1385             JZ YEMIT1               ; 2 but there's no point in wanting to save time here:
1386 YEMIT2                              ;
1387     .IFDEF  TERMINAL5WIRES          ;
1388             BIT.B #CTS,&HANDSHAKIN  ; 3
1389             JNZ YEMIT2              ; 2
1390     .ENDIF                          ;
1391 YEMIT                               ; hi7/4~ lo:12/9~ send/send_not  echo to terminal
1392             .word   4882h           ; 4882h = MOV Y,&<next_adr>
1393             .word   TERM_TXBUF      ; 3
1394             mNEXT                   ; 4
1395 ; ----------------------------------;
1396 AYEMIT_RET  FORTHtoASM              ; 0     YEMII NEXT address
1397             SUB #2,IP               ; 1 reset YEMIT NEXT address to AYEMIT_RET
1398 WAITaKEY    BIT #UCRXIFG,&TERM_IFG  ; 3 new char in TERMRXBUF ?
1399             JNZ AKEYREAD            ; 2 yes
1400             JZ WAITaKEY             ; 2 no
1401 ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;
1402 ; stops the 2th stopwatch           ; best case result: 26~/22~ (with/without echo) ==> 385/455 kBds/MHz
1403 ; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^;
1404
1405 ; ----------------------------------;
1406 ENDACCEPT                           ; --- Org Ptr       r-- ACCEPT_ret
1407 ; ----------------------------------;
1408             CMP #0,&LINE            ; if LINE <> 0...
1409             JZ ACCEPTEND            ;
1410             ADD #1,&LINE            ; ...increment LINE
1411 ACCEPTEND   SUB @PSP+,TOS           ; -- len'
1412             MOV @RSP+,IP            ; 2  return to INTERPRET with GIE=0: FORTH is protected against any interrupt...
1413 ; ----------------------------------;
1414             MOV #LPM0+GIE,&LPM_MODE ; reset LPM_MODE to default mode LPM0 for next line of input stream
1415 ; ----------------------------------;
1416             mNEXT                   ; ...until next falling down to LPMx mode of (ACCEPT) part1,
1417 ; **********************************;    i.e. when the FORTH interpreter has no more to do.
1418
1419     .IFDEF DEFER_ACCEPT
1420
1421 ; CIB           --  addr          of Current Input Buffer
1422             FORTHWORD "CIB"         ; constant, may be redirected as SDIB_ORG by OPEN.
1423 FCIB        mDOCON                  ; Code Field Address (CFA) of FCIB
1424 PFACIB      .WORD    TIB_ORG        ; Parameter Field Address (PFA) of FCIB
1425
1426 ; REFILL    accept one line from input and leave org len of input buffer
1427 ; : REFILL CIB DUP TIB_LEN ACCEPT ;   -- CIB len    shared by QUIT and [ELSE]
1428 REFILL      SUB #6,PSP              ;2
1429             MOV TOS,4(PSP)          ;3
1430             MOV #TIB_LEN,TOS        ;2
1431             MOV &PFACIB,0(PSP)      ;5
1432             MOV @PSP,2(PSP)         ;4
1433             JMP ACCEPT              ;2
1434
1435     .ELSE
1436
1437 ; REFILL    accept one line from input and leave org len of input buffer
1438 ; : REFILL TIB DUP TIB_LEN ACCEPT ;   -- TIB len    shared by QUIT and [ELSE]
1439 REFILL      SUB #6,PSP              ;2
1440             MOV TOS,4(PSP)          ;3
1441             MOV #TIB_LEN,TOS        ;2
1442             MOV #TIB_ORG,0(PSP)     ;4
1443             MOV @PSP,2(PSP)         ;4
1444             JMP ACCEPT              ;2
1445
1446     .ENDIF
1447
1448 ; ------------------------------------------------------------------------------
1449 ; TERMINAL I/O, output part
1450 ; ------------------------------------------------------------------------------
1451
1452 ;https://forth-standard.org/standard/core/EMIT
1453 ;C EMIT     c --    output character to the selected output device ; primary DEFERred word
1454             FORTHWORD "EMIT"
1455 EMIT        MOV @PC+,PC             ;3 Code Field Address (CFA) of EMIT
1456 PFAEMIT     .word   BODYEMIT        ;  Parameter Field Address (PFA) of EMIT, with its default value
1457 BODYEMIT    MOV TOS,Y               ;  output character to the default output: TERMINAL
1458             MOV @PSP+,TOS           ; 2
1459             JMP YEMIT1              ;9  12~
1460
1461     .ENDIF  ; HALFDUPLEX
1462
1463 ;Z ECHO     --      connect terminal output (default)
1464             FORTHWORD "ECHO"
1465 ECHO        MOV #4882h,&YEMIT       ; 4882h = MOV Y,&<next_adr>
1466             MOV #0,&LINE            ;
1467             mNEXT
1468
1469 ;Z NOECHO   --      disconnect terminal output
1470             FORTHWORD "NOECHO"
1471 NOECHO      MOV #NEXT,&YEMIT        ;  NEXT = 4030h = MOV @IP+,PC
1472             MOV #1,&LINE            ;
1473             mNEXT
1474
1475 ;https://forth-standard.org/standard/core/SPACE
1476 ;C SPACE   --               output a space
1477             FORTHWORD "SPACE"
1478 SPACE       SUB #2,PSP              ;1
1479             MOV TOS,0(PSP)          ;3
1480             MOV #20h,TOS            ;2
1481             JMP EMIT                ;17~  23~
1482
1483 ;https://forth-standard.org/standard/core/SPACES
1484 ;C SPACES   n --            output n spaces
1485             FORTHWORD "SPACES"
1486 SPACES      CMP #0,TOS
1487             JZ ONEDROP
1488             PUSH IP
1489             MOV #SPACESNEXT,IP
1490             JMP SPACE               ;25~
1491 SPACESNEXT  FORTHtoASM
1492             SUB #2,IP               ;1
1493             SUB #1,TOS              ;1
1494             JNZ SPACE               ;25~ ==> 27~ by space ==> 2.963 MBds @ 8 MHz
1495 DROPEXIT    MOV @RSP+,IP            ;
1496 ONEDROP     MOV @PSP+,TOS           ; --         drop n
1497             mNEXT                   ;
1498
1499 ;https://forth-standard.org/standard/core/TYPE
1500 ;C TYPE    adr len --     type line to terminal
1501             FORTHWORD "TYPE"
1502 TYPE        CMP #0,TOS
1503             JZ TWODROP              ; abort fonction
1504             PUSHM #2,TOS            ;4 R-- len,IP
1505             MOV #TYPE_NEXT,IP
1506 TYPELOOP    MOV @PSP,Y              ;2 -- adr x       ; 30~ char loop
1507             MOV.B @Y+,TOS           ;2
1508             MOV Y,0(PSP)            ;3 -- adr+1 char
1509             SUB #2,PSP              ;1 emit consumes one cell
1510             JMP EMIT                ;15
1511 TYPE_NEXT   FORTHtoASM
1512             SUB #2,IP               ;1
1513             SUB #1,2(RSP)           ;4 len-1
1514             JNZ TYPELOOP            ;2
1515             POPM #2,TOS             ;4 POPM IP,TOS
1516 TWODROP     ADD #2,PSP              ;
1517             MOV @PSP+,TOS           ; --
1518             mNEXT                   ;
1519
1520 ;https://forth-standard.org/standard/core/CR
1521 ;C CR      --               send CR to the output device
1522             FORTHWORD "CR"
1523 CR          MOV @PC+,PC             ;3 Code Field Address (CFA) of CR
1524 PFACR       .word   BODYCR          ;  Parameter Field Address (PFA) of CR, with its default value
1525 BODYCR      mDOCOL                  ;  send CR to the default output device
1526             .word   XSQUOTE
1527             .byte   2,13,10
1528             .word   TYPE,EXIT
1529
1530 ; ------------------------------------------------------------------------------
1531 ; STRINGS PROCESSING
1532 ; ------------------------------------------------------------------------------
1533
1534 ;Z (S")     -- addr u   run-time code for S"
1535 ; get address and length of string.
1536 XSQUOTE     SUB #4,PSP              ; 1 -- x x TOS      ; push old TOS on stack
1537             MOV TOS,2(PSP)          ; 3 -- TOS x x      ; and reserve one cell on stack
1538             MOV.B @IP+,TOS          ; 2 -- x u          ; u = lenght of string
1539             MOV IP,0(PSP)           ; 3 -- addr u
1540             ADD TOS,IP              ; 1 -- addr u       IP=addr+u=addr(end_of_string)
1541             BIT #1,IP               ; 1 -- addr u       IP=addr+u   Carry set/clear if odd/even
1542             ADDC #0,IP              ; 1 -- addr u       IP=addr+u aligned
1543             mNEXT                   ; 4  16~
1544
1545 ;https://forth-standard.org/standard/core/Sq
1546 ;C S"       --             compile in-line string
1547             FORTHWORDIMM "S\34"     ; immediate
1548 SQUOTE      MOV #0,&CAPS            ; CAPS OFF
1549             mDOCOL
1550             .word   lit,XSQUOTE,COMMA
1551 SQUOTE1     .word   lit,'"',WORDD   ; -- c-addr (= HERE)
1552             FORTHtoASM
1553             MOV @RSP+,IP
1554             MOV #32,&CAPS           ; CAPS ON
1555             MOV.B @TOS,TOS          ; -- u
1556             SUB #1,TOS              ; -- u-1 bytes
1557             ADD TOS,&DDP
1558             MOV @PSP+,TOS
1559 CELLPLUSALIGN
1560             BIT #1,&DDP             ;3 carry set if odd
1561             ADDC #2,&DDP            ;4  +2/+3 bytes
1562             mNEXT
1563
1564 ;https://forth-standard.org/standard/core/Dotq
1565 ;C ."       --              compile string to print
1566             FORTHWORDIMM ".\34"     ; immediate
1567 DOTQUOTE    mDOCOL
1568             .word   SQUOTE
1569             .word   lit,TYPE,COMMA,EXIT
1570
1571 ;-------------------------------------------------------------------------------
1572 ; INTERPRETER
1573 ;-------------------------------------------------------------------------------
1574
1575 ;https://forth-standard.org/standard/core/WORD
1576 ;C WORD   char -- addr        Z=1 if len=0
1577 ; parse a word delimited by char separator, by default "word" is capitalized ([CAPS]=32)
1578             FORTHWORD "WORD"
1579 WORDD       MOV #SOURCE_LEN,S       ;2 -- separator
1580             MOV @S+,X               ;2               X = str_len
1581             MOV @S+,W               ;2               W = str_org
1582             ADD W,X                 ;1               W = str_org    X = str_org + str_len = str_end
1583             ADD @S+,W               ;2               W = str_org + >IN = str_ptr    X = str_end
1584             MOV @S,Y                ;2 -- separator  W = str_ptr    X = str_end     Y = HERE, as dst_ptr
1585 SKIPCHARLOO CMP W,X                 ;1               str_ptr = str_end ?
1586             JZ EOL_END              ;2 -- separator  if yes : End Of Line !
1587             CMP.B @W+,TOS           ;2               does char = separator ?
1588             JZ SKIPCHARLOO          ;2 -- separator  if yes
1589 SCANWORD    SUB #1,W                ;1
1590             MOV #96,T               ;2              T = 96 = ascii(a)-1 (test value set in a register before SCANWORD loop)
1591 SCANWORDLOO                         ; -- separator  15/24 cycles loop for upper/lower case char... write words in upper case !
1592             MOV.B S,0(Y)            ;3              first time make room in dst for word length, then put char @ dst.
1593             CMP W,X                 ;1              str_ptr = str_end ?
1594             JZ SCANWORDEND          ;2              if yes
1595             MOV.B @W+,S             ;2
1596             CMP.B S,TOS             ;1              does char = separator ?
1597             JZ SCANWORDEND          ;2              if yes
1598             ADD #1,Y                ;1              increment dst just before test loop
1599             CMP.B S,T               ;1              char U< 'a' ?  ('a'-1 U>= char) this condition is tested at each loop
1600             JC SCANWORDLOO          ;2              15~ upper case char loop
1601             CMP.B #123,S            ;2              char U>= 'z'+1 ?
1602             JC SCANWORDLOO          ;2              if yes
1603             SUB.B &CAPS,S           ;3              convert lowercase char to uppercase if CAPS ON (CAPS=32)
1604             JMP SCANWORDLOO         ;2              24~ lower case char loop
1605 SCANWORDEND SUB &SOURCE_ADR,W       ;3 -- separator  W=str_ptr - str_org = new >IN (first char separator next)
1606             MOV W,&TOIN             ;3               update >IN
1607 EOL_END     MOV &DDP,TOS            ;3 -- c-addr
1608             SUB TOS,Y               ;1               Y=Word_Length
1609             MOV.B Y,0(TOS)          ;3
1610             mNEXT                   ;4 -- c-addr     40 words      Z=1 <==> lenght=0 <==> EOL
1611
1612 ;https://forth-standard.org/standard/core/FIND
1613 ;C FIND   c-addr -- c-addr 0   if not found ; flag Z=1
1614 ;C                  CFA -1      if found     ; flag Z=0
1615 ;C                  CFA  1      if immediate ; flag Z=0
1616 ; compare WORD at c-addr (HERE)  with each of words in each of listed vocabularies in CONTEXT
1617 ; FIND to WORDLOOP  : 14/20 cycles,
1618 ; mismatch word loop: 13 cycles on len, +7 cycles on first char,
1619 ;                     +10 cycles char loop,
1620 ; VOCLOOP           : 12/18 cycles,
1621 ; WORDFOUND to end  : 21 cycles.
1622 ; note: with 16 threads vocabularies, FIND takes about 75% of CORETEST.4th processing time
1623             FORTHWORD "FIND"        ;  -- c-addr
1624 FIND        SUB #2,PSP              ;1 -- ???? c-addr       reserve one cell here, not at FINDEND because interacts with flag Z
1625             MOV TOS,S               ;1                      S=c-addr
1626             MOV.B @S,rDOCON         ;2                      R5= string count
1627             MOV.B #80h,rDODOES      ;2                      R4= immediate mask
1628             MOV #CONTEXT,T          ;2
1629 VOCLOOP     MOV @T+,TOS             ;2 -- ???? VOC_PFA      T=CTXT+2
1630             CMP #0,TOS              ;1                      no more vocabulary in CONTEXT ?
1631             JZ FINDEND              ;2 -- ???? 0            yes ==> exit; Z=1
1632     .SWITCH THREADS
1633     .CASE   1
1634     .ELSECASE                       ;                       search thread add 6cycles  5words
1635 MAKETHREAD  MOV.B 1(S),Y            ;3 -- ???? VOC_PFA0     S=c-addr Y=CHAR0
1636             AND.B #(THREADS-1)*2,Y  ;2 -- ???? VOC_PFA0     Y=thread offset
1637             ADD Y,TOS               ;1 -- ???? VOC_PFAx
1638     .ENDCASE
1639             ADD #2,TOS              ;1 -- ???? VOC_PFA+2
1640 WORDLOOP    MOV -2(TOS),TOS         ;3 -- ???? [VOC_PFA]    [VOC_PFA] first, then [LFA]
1641             CMP #0,TOS              ;1 -- ???? NFA          no more word in the thread ?
1642             JZ VOCLOOP              ;2 -- ???? NFA          yes ==> search next voc in context
1643             MOV TOS,X               ;1
1644             MOV.B @X+,Y             ;2                      TOS=NFA,X=NFA+1,Y=NFA_char
1645             BIC.B rDODOES,Y         ;1                      hide Immediate bit
1646 LENCOMP     CMP.B rDOCON,Y          ;1                      compare lenght
1647             JNZ WORDLOOP            ;2 -- ???? NFA          13~ word loop on lenght mismatch
1648             MOV S,W                 ;1                      W=c-addr
1649 CHARCOMP    CMP.B @X+,1(W)          ;4                      compare chars
1650             JNZ WORDLOOP            ;2 -- ???? NFA          20~ word loop on first char mismatch
1651             ADD #1,W                ;1
1652             SUB.B #1,Y              ;1                      decr count
1653             JNZ CHARCOMP            ;2 -- ???? NFA          10~ char loop
1654
1655 WORDFOUND   BIT #1,X                ;1
1656             ADDC #0,X               ;1
1657             MOV X,S                 ;1                      S=aligned CFA
1658             MOV.B @TOS,W            ;2 -- ???? NFA          W=NFA_first_char
1659             MOV #1,TOS              ;1 -- ???? 1            preset immediate flag
1660             CMP.B #0,W              ;1                      W is negative if immediate flag
1661             JN FINDEND              ;2 -- ???? 1
1662             SUB #2,TOS              ;1 -- ???? -1
1663 FINDEND     MOV S,0(PSP)            ;3 not found: -- c-addr 0                           flag Z=1
1664                                     ;      found: -- xt -1|+1 (not immediate|immediate) flag Z=0
1665             MOV #xdocon,rDOCON      ;2
1666             MOV #xdodoes,rDODOES    ;2
1667             mNEXT                   ;4 42/47 words
1668
1669     .IFDEF MPY_32
1670
1671 ;https://forth-standard.org/standard/core/toNUMBER
1672 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
1673 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
1674 ; Conversion continues left-to-right until a character that is not convertible, including '.', ',' or '_',
1675 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
1676 ; or the first character past the end of the string if the string was entirely converted.
1677 ; u2 is the number of unconverted characters in the string.
1678 ; An ambiguous condition exists if ud2 overflows during the conversion.
1679 ;C >NUMBER  ud1lo ud1hi addr1 cnt1 -- ud2lo ud2hi addr2 cnt2
1680             FORTHWORD ">NUMBER"     ; 23 cycles + 32/34 cycles DEC/HEX char loop
1681 TONUMBER    MOV @PSP+,S             ;2 -- ud1lo ud1hi cnt1  S = addr1
1682             MOV @PSP+,Y             ;2 -- ud1lo cnt1        Y = ud1hi
1683             MOV @PSP,X              ;2 -- x cnt1            X = ud1lo
1684             SUB #4,PSP              ;1 -- x x x cnt
1685             MOV &BASE,T             ;3
1686 TONUMLOOP   MOV.B @S,W              ;2 -- x x x cnt         S=adr, T=base, W=char, X=udlo, Y=udhi
1687 DDIGITQ     SUB.B #30h,W            ;2                      skip all chars < '0'
1688             CMP.B #10,W             ;2                      char was U< 10 (U< ':') ?
1689             JLO DDIGITQNEXT         ;2                      no
1690             SUB.B #7,W              ;2
1691             CMP.B #10,W             ;2
1692             JLO TONUMEND            ;2 -- x x x cnt         exit if '9' < char < 'A'
1693 DDIGITQNEXT CMP T,W                 ;1                      digit-base
1694             BIC #Z,SR               ;1                      reset Z before jmp TONUMEND because...
1695             JHS TONUMEND            ;2                      ...QNUMBER conversion will be true if Z = 1  :-(
1696 UDSTAR      MOV X,&MPY32L           ;3                      Load 1st operand (ud1lo)
1697             MOV Y,&MPY32H           ;3                      Load 1st operand (ud1hi)
1698             MOV T,&OP2              ;3                      Load 2nd operand with BASE
1699             MOV &RES0,X             ;3                      lo result in X (ud2lo)
1700             MOV &RES1,Y             ;3                      hi result in Y (ud2hi)
1701 MPLUS       ADD W,X                 ;1                      ud2lo + digit
1702             ADDC #0,Y               ;1                      ud2hi + carry
1703 TONUMPLUS   ADD #1,S                ;1                      adr+1
1704             SUB #1,TOS              ;1 -- x x x cnt         cnt-1
1705             JNZ TONUMLOOP           ;2                      if count <>0
1706 TONUMEND    MOV S,0(PSP)            ;3 -- x x addr2 cnt2
1707             MOV Y,2(PSP)            ;3 -- x ud2hi addr2 cnt2
1708             MOV X,4(PSP)            ;3 -- ud2lo ud2hi addr2 cnt2
1709             mNEXT                   ;4 41 words
1710
1711 ; ?NUMBER makes the interface between >NUMBER and INTERPRET; it's a subset of INTERPRET.
1712 ; convert a string to a signed number; FORTH 2012 prefixes $, %, # are recognized
1713 ; 32 bits numbers (with decimal point) and fixed point signed numbers (with a comma) are recognized.
1714 ; digits separator '_' is recognized
1715 ; prefixes # % $ and - are processed before calling >NUMBER
1716 ; not convertible chars '.' , ',' and '_' are processed as >NUMBER exits
1717 ;Z ?NUMBER  addr -- n|d -1  if convert ok ; flag Z=0, UF9=1 if double
1718 ;Z          addr -- addr 0  if convert ko ; flag Z=1
1719 QNUMBER
1720             MOV &BASE,T             ;3                          T=BASE
1721             MOV #0,S                ;1                          S=sign of result
1722             PUSHM #3,IP             ;5                          R-- IP sign base
1723             MOV #TONUMEXIT,IP       ;2                          set TONUMEXIT as return from >NUMBER
1724             MOV #0,X                ;1                          X=ud1lo
1725             MOV #0,Y                ;1                          Y=ud1hi
1726             SUB #8,PSP              ;1 -- x x x x addr          save TOS and make room for >NUMBER
1727             MOV TOS,6(PSP)          ;3 -- addr x x x addr
1728             MOV TOS,S               ;1                          S=addrr
1729             MOV.B @S+,TOS           ;2 -- addr x x x cnt        TOS=count
1730 QNUMLDCHAR  MOV.B @S,W              ;2                          W=char
1731             CMP.B #'-',W            ;2
1732             JLO QBINARY             ;2                          jump if char < '-'
1733             JNZ DDIGITQ             ;2 -- addr x x x cnt        jump if char > '-'
1734             MOV #-1,2(RSP)          ;3 R-- IP sign base         set sign flag
1735             JMP TONUMPLUS           ;2
1736 QBINARY     MOV #2,T                ;1                          preset base 2
1737             SUB.B #'%',W            ;2                          binary number ?
1738             JZ PREFIXED             ;2
1739 QDECIMAL    ADD #8,T                ;1
1740             ADD.B #2,W              ;1                          decimal number ?
1741             JZ PREFIXED             ;2
1742 QHEXA       MOV #16,T               ;2
1743             SUB.B #1,W              ;1                          hex number ?
1744             JNZ TONUMLOOP           ;2 -- addr x x x cnt        other cases will cause >NUMBER exit
1745 PREFIXED    ADD #1,S                ;1
1746             SUB #1,TOS              ;1 -- addr x x x cnt-1      S=adr+1 TOS=count-1
1747             JMP QNUMLDCHAR          ;2
1748 ; ----------------------------------;
1749 TONUMEXIT   FORTHtoASM              ;  -- addr ud2lo-hi addr2 cnt2      R-- IP sign BASE    S=addr2
1750 ; ----------------------------------;
1751             JZ QNUMNEXT             ;2                                  if conversion is ok
1752             SUB #2,IP
1753             CMP.B #28h,W            ;                                   rejected char by >NUMBER is a underscore ?
1754             JZ TONUMPLUS            ;                                   skip it
1755         .IFDEF DOUBLE_NUMBERS       ;                                   DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1756             BIT #UF9,SR
1757             JNZ QNUMNEXT
1758             BIS #UF9,SR             ;2                                  set double number flag
1759         .ENDIF
1760         .IFDEF DOUBLE_INPUT
1761             CMP.B #0F7h,W           ;2                                  rejected char by >NUMBER is a decimal point ?
1762             JZ TONUMPLUS            ;2                                  skip it
1763         .ENDIF
1764         .IFDEF FIXPOINT_INPUT       ;
1765             CMP.B #0F5h,W           ;2                                  rejected char by >NUMBER is a comma ?
1766             JNZ QNUMNEXT            ;2                                  no, that will be followed by abort on conversion error
1767 S15Q16      MOV TOS,W               ;1 -- addr ud2lo x x x              yes   W=cnt2
1768             MOV #0,X                ;1 -- addr ud2lo x 0 x              init X = ud2lo' = 0
1769 S15Q16LOOP  MOV X,2(PSP)            ;3 -- addr ud2lo ud2lo' ud2lo' x    0(PSP) = ud2lo'
1770             SUB.B #1,W              ;1                                  decrement cnt2
1771             MOV W,X                 ;1                                  X = cnt2-1
1772             ADD S,X                 ;1                                  X = end_of_string-1, first...
1773             MOV.B @X,X              ;2                                  X = last char of string first (keep in mind: reverse conversion)
1774             SUB.B #30h,X            ;2                                  char --> digit conversion
1775             CMP.B #10,X             ;2
1776             JLO QS15Q16DIGI         ;2
1777             SUB.B #7,X              ;2
1778             CMP.B #10,X             ;2                                  to skip all chars between "9" and "A"
1779             JLO S15Q16EOC           ;2                                  end of conversion on first rejected char (normally: ',')
1780 QS15Q16DIGI CMP T,X                 ;1                                  R-- IP sign BASE    is X a digit ?
1781             JHS S15Q16EOC           ;2 -- addr ud2lo ud2lo' x ud2lo'    if no goto QNUMNEXT (abort then)
1782             MOV X,0(PSP)            ;3 -- addr ud2lo ud2lo' digit x
1783             MOV T,TOS               ;1 -- addr ud2lo ud2lo' digit base  R-- IP sign base
1784             PUSHM #3,S              ;6                                  PUSH S,T,W: R-- IP sign base addr2 base cnt2
1785             CALL #MUSMOD            ;4 -- addr ud2lo ur uqlo uqhi
1786             POPM #3,S               ;6                                  restore W,T,S: R-- IP sign BASE
1787             JMP S15Q16LOOP          ;2                                  W=cnt
1788 S15Q16EOC   MOV 4(PSP),2(PSP)       ;5 -- addr ud2lo ud2hi uqlo x       ud2lo from >NUMBER part1 becomes here ud2hi part of Q15.16
1789             MOV @PSP,4(PSP)         ;4 -- addr ud2lo ud2hi x x          uqlo becomes ud2lo part of Q15.16
1790             MOV W,TOS               ;1 -- addr ud2lo ud2hi x cnt2
1791             CMP.B #0,TOS            ;1                                  TOS = 0 if end of conversion (happy end)
1792         .ENDIF                      ;
1793 ; ----------------------------------;
1794 QNUMNEXT    POPM #3,IP              ;4 -- addr ud2lo-hi x cnt2          POPM T,S,IP  S = sign flag = {-1;0}
1795             MOV S,TOS               ;1 -- addr ud2lo-hi x sign
1796             MOV T,&BASE             ;3
1797             JZ QNUMOK               ;2 -- addr ud2lo-hi x sign          conversion OK
1798 QNUMKO
1799         .IFDEF DOUBLE_NUMBERS       ;
1800             BIC #UF9,SR             ;2                                  reset flag UF9, before use as double number flag
1801         .ENDIF
1802             ADD #6,PSP              ;1 -- addr sign
1803             AND #0,TOS              ;1 -- addr ff                       TOS=0 and Z=1 ==> conversion ko
1804             mNEXT                   ;4
1805 ; ----------------------------------;
1806         .IFDEF DOUBLE_NUMBERS
1807 QNUMOK      ADD #2,PSP              ;1 -- addr ud2lo-hi cnt2
1808             MOV 2(PSP),4(PSP)       ;  -- udlo udlo udhi sign
1809             MOV @PSP+,0(PSP)        ;4 -- udlo udhi sign                note : PSP is incremented before write back.
1810             XOR #-1,TOS             ;1 -- udlo udhi inv(sign)
1811             JNZ QDOUBLE             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
1812 Q2NEGATE    XOR #-1,TOS             ;1 -- udlo udhi tf
1813             XOR #-1,2(PSP)          ;3
1814             XOR #-1,0(PSP)          ;3 -- (dlo dhi)-1 tf
1815             ADD #1,2(PSP)           ;3
1816             ADDC #0,0(PSP)          ;3 -- dlo dhi tf
1817 QDOUBLE     BIT #UF9,SR             ;2                                  decimal point added ?
1818             JNZ QNUMEND             ;2                                  leave double
1819             ADD #2,PSP              ;1                                  leave number
1820 QNUMEND     mNEXT                   ;4                                  TOS<>0 and Z=0 ==> conversion ok
1821         .ELSE
1822 QNUMOK      ADD #4,PSP              ;1 -- addr ud2lo sign
1823             MOV @PSP+,0(PSP)        ;4 -- udlo sign                     note : PSP is incremented before write back !!!
1824             XOR #-1,TOS             ;1 -- udlo inv(sign)
1825             JNZ QNUMEND             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
1826 QNEGATE     XOR #-1,0(PSP)          ;3
1827             ADD #1,0(PSP)           ;3 -- n tf
1828             XOR #-1,TOS             ;1 -- udlo udhi tf                  TOS=-1 and Z=0
1829 QNUMEND     mNEXT                   ;4                                  TOS=-1 and Z=0 ==> conversion ok
1830         .ENDIF ; DOUBLE_NUMBERS
1831 ; ----------------------------------;128 words
1832
1833     .ELSE ; no hardware MPY
1834
1835 ; T.I. SIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud
1836 ;https://forth-standard.org/standard/core/UMTimes
1837 ;C UM*     u1 u2 -- ud   unsigned 16x16->32 mult.
1838             FORTHWORD "UM*"
1839 UMSTAR      MOV @PSP,S              ;2 MDlo
1840 UMSTAR1     MOV #0,T                ;1 MDhi=0
1841             MOV #0,X                ;1 RES0=0
1842             MOV #0,Y                ;1 RES1=0
1843             MOV #1,W                ;1 BIT TEST REGISTER
1844 UMSTARLOOP  BIT W,TOS               ;1 TEST ACTUAL BIT MRlo
1845             JZ UMSTARNEXT           ;2 IF 0: DO NOTHING
1846             ADD S,X                 ;1 IF 1: ADD MDlo TO RES0
1847             ADDC T,Y                ;1      ADDC MDhi TO RES1
1848 UMSTARNEXT  ADD S,S                 ;1 (RLA LSBs) MDlo x 2
1849             ADDC T,T                ;1 (RLC MSBs) MDhi x 2
1850             ADD W,W                 ;1 (RLA) NEXT BIT TO TEST
1851             JNC UMSTARLOOP          ;2 IF BIT IN CARRY: FINISHED    10~ loop
1852             MOV X,0(PSP)            ;3 low result on stack
1853             MOV Y,TOS               ;1 high result in TOS
1854             mNEXT                   ;4 17 words
1855
1856 ;https://forth-standard.org/standard/core/toNUMBER
1857 ; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits,
1858 ; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE.
1859 ; Conversion continues left-to-right until a character that is not convertible, including '.', ',' or '_',
1860 ; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character
1861 ; or the first character past the end of the string if the string was entirely converted.
1862 ; u2 is the number of unconverted characters in the string.
1863 ; An ambiguous condition exists if ud2 overflows during the conversion.
1864 ;C >NUMBER  ud1lo|ud1hi addr1 count1 -- ud2lo|ud2hi addr2 count2
1865             FORTHWORD ">NUMBER"
1866 TONUMBER    MOV @PSP,S              ;2                          S=adr
1867             MOV TOS,T               ;1                          T=count
1868             MOV &BASE,W             ;3
1869 TONUMLOOP   MOV.B @S,Y              ;2 -- ud1lo ud1hi x x       S=adr, T=count, W=BASE, Y=char
1870 DDIGITQ     SUB.B #30h,Y            ;2                          skip all chars < '0'
1871             CMP.B #10,Y             ;2                          char was > "9" ?
1872             JLO DDIGITQNEXT         ;2 -- ud1lo ud1hi x x       no: good end
1873             SUB.B #07,Y             ;2                          skip all chars between "9" and "A"
1874             CMP.B #10,Y             ;2                          char was < "A" ?
1875             JLO TONUMEND            ;2                          yes: for bad end
1876 DDIGITQNEXT CMP W,Y                 ;1 -- ud1lo ud1hi x x       digit-base
1877             BIC #Z,SR               ;1                          reset Z before jmp TONUMEND because...
1878             JHS TONUMEND            ;2                          ...QNUMBER conversion will be true if Z = 1  :-(
1879 UDSTAR      PUSHM #6,IP             ;8 -- ud1lo ud1hi x x                                           r-- IP adr count base x digit
1880             MOV 2(PSP),S            ;3 -- ud1lo ud1hi x x       S=ud1hi
1881             MOV W,TOS               ;1 -- ud1lo ud1hi x base
1882             MOV #UMSTARNEXT1,IP     ;2
1883 UMSTARONE   JMP UMSTAR1             ;2 ud1hi * base -- x ud3hi  X=ud3lo
1884 UMSTARNEXT1 FORTHtoASM              ;  -- ud1lo ud1hi x ud3hi
1885             MOV X,2(RSP)            ;3                                                              r-- IP adr count base ud3lo digit
1886             MOV 4(PSP),S            ;3 -- ud1lo ud1hi x ud3hi   S=ud1lo
1887             MOV 4(RSP),TOS          ;3 -- ud1lo ud1hi x base
1888             MOV #UMSTARNEXT2,IP     ;2
1889 UMSTARTWO   JMP UMSTAR1             ;2 -- ud1lo ud1hi x ud4hi   X=ud4lo
1890 UMSTARNEXT2 FORTHtoASM              ;  -- ud1lo ud1hi x ud4hi
1891 MPLUS       ADD @RSP+,X             ;2 -- ud1lo ud1hi x ud4hi   X=ud4lo+digit=ud2lo                 r-- IP adr count base ud3lo
1892             ADDC @RSP+,TOS          ;2 -- ud1lo ud1hi x ud2hi   TOS=ud4hi+ud3lo+carry=ud2hi         r-- IP adr count base
1893             MOV X,4(PSP)            ;3 -- ud2lo ud1hi x ud2hi
1894             MOV TOS,2(PSP)          ;3 -- ud2lo ud2hi x x                                           r-- IP adr count base
1895             POPM #4,IP              ;6 -- ud2lo ud2hi x x       W=base, T=count, S=adr, IP=prevIP   r--
1896 TONUMPLUS   ADD #1,S                ;1
1897             SUB #1,T                ;1
1898             JNZ TONUMLOOP           ;2 -- ud2lo ud2hi x x       S=adr+1, T=count-1, W=base     68 cycles char loop
1899 TONUMEND    MOV S,0(PSP)            ;3 -- ud2lo ud2hi adr2 count2
1900             MOV T,TOS               ;1 -- ud2lo ud2hi adr2 count2
1901             mNEXT                   ;4 50/82 words/cycles, W = BASE
1902
1903 ; convert a string to a signed number
1904 ;Z ?NUMBER  addr -- n|d -1  if convert ok ; flag Z=0, UF9=1 if double
1905 ;Z          addr -- addr 0  if convert ko ; flag Z=1
1906 ; FORTH 2012 prefixes $, %, # are recognised
1907 ; 32 bits numbers (with decimal point) are recognised
1908 ; with FIXPOINT_INPUT switched ON, fixed point signed numbers (with a comma) are recognised.
1909 ; prefixes # % $ - are processed before calling >NUMBER, decimal point and comma are >NUMBER exits
1910 ;            FORTHWORD "?NUMBER"
1911 QNUMBER
1912             MOV &BASE,T             ;3          T=BASE
1913             MOV #0,S                ;1
1914             PUSHM #3,IP             ;5          R-- IP sign base (push IP,S,T)
1915             MOV #TONUMEXIT,IP       ;2          define >NUMBER return
1916             MOV T,W                 ;1          W=BASE
1917             SUB #8,PSP              ;1 -- x x x x addr
1918             MOV TOS,6(PSP)          ;3 -- addr x x x addr
1919             MOV #0,4(PSP)           ;3
1920             MOV #0,2(PSP)           ;3 -- addr ud=0 x addr
1921             MOV TOS,S               ;1
1922             MOV.B @S+,T             ;2 -- addr ud=0 x x     S=adr, T=count
1923 QNUMLDCHAR  MOV.B @S,Y              ;2                      Y=char
1924             CMP.B #'-',Y            ;2
1925             JLO QBINARY             ;2                      if char < '-'
1926             JNZ DDIGITQ             ;2                      if char > '-'
1927             MOV #-1,2(RSP)          ;3                      R-- IP sign base
1928             JMP TONUMPLUS           ;2
1929 QBINARY     MOV #2,W                ;1                      preset base 2
1930             SUB.B #'%',Y            ;2                      binary number ?
1931             JZ PREFIXED             ;2
1932 QDECIMAL    ADD #8,W                ;1
1933             ADD.B #2,Y              ;1                      decimal number ?
1934             JZ PREFIXED             ;2
1935 QHEXA       MOV #16,W               ;1
1936             SUB.B #1,Y              ;2                      hex number ?
1937             JNZ TONUMLOOP           ;2 -- addr ud=0 x x     other cases will cause >NUMBER exit
1938 PREFIXED    ADD #1,S                ;1
1939             SUB #1,T                ;1 -- addr ud=0 x x     S=adr+1 T=count-1
1940             JMP QNUMLDCHAR          ;
1941 ; ----------------------------------;42
1942 TONUMEXIT   FORTHtoASM              ;  -- addr ud2lo-hi addr2 cnt2      R-- IP sign BASE    S=addr2,T=cnt2
1943 ; ----------------------------------;
1944             JZ QNUMNEXT             ;2                                  if conversion is ok
1945             SUB #2,IP
1946             CMP.B #28h,Y            ;                                   rejected char by >NUMBER is a underscore ?
1947             JZ TONUMPLUS            ;                                   skip it
1948         .IFDEF DOUBLE_NUMBERS       ;                                   DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT
1949             BIT #UF9,SR
1950             JNZ QNUMNEXT
1951             BIS #UF9,SR             ;2                                  set double number flag
1952         .ENDIF
1953         .IFDEF DOUBLE_INPUT
1954             CMP.B #0F7h,Y           ;2                                  rejected char by >NUMBER is a decimal point ?
1955             JZ TONUMPLUS            ;2                                  to terminate conversion
1956         .ENDIF
1957         .IFDEF FIXPOINT_INPUT       ;
1958             CMP.B #0F5h,Y           ;2                                  rejected char by >NUMBER is a comma ?
1959             JNZ QNUMNEXT            ;2                                  no, that will be followed by abort on conversion error
1960 S15Q16      MOV #0,X                ;1 -- addr ud2lo x 0 x              init ud2lo' = 0
1961 S15Q16LOOP  MOV X,2(PSP)            ;3 -- addr ud2lo ud2lo' ud2lo' x    X = 0(PSP) = ud2lo'
1962             SUB.B #1,T              ;1                                  decrement cnt2
1963             MOV T,X                 ;1                                  X = cnt2-1
1964             ADD S,X                 ;1                                  X = end_of_string-1, first...
1965             MOV.B @X,X              ;2                                  X = last char of string, first...
1966             SUB.B #30h,X            ;2                                  char --> digit conversion
1967             CMP.B #10,X             ;2
1968             JLO QS15Q16DIGI         ;2
1969             SUB.B #7,X              ;2
1970             CMP.B #10,X             ;2
1971             JLO S15Q16EOC           ;2
1972 QS15Q16DIGI CMP W,X                 ;1                                  R-- IP sign BASE, W=BASE,    is X a digit ?
1973             JHS S15Q16EOC           ;2 -- addr ud2lo ud2lo' x ud2lo'    if no
1974             MOV X,0(PSP)            ;3 -- addr ud2lo ud2lo' digit x
1975             MOV W,TOS               ;1 -- addr ud2lo ud2lo' digit base  R-- IP sign base
1976             PUSHM #3,S              ;5                                  PUSH S,T,W: R-- IP sign base addr2 cnt2 base
1977             CALL #MUSMOD            ;4 -- addr ud2lo ur uqlo uqhi
1978             POPM #3,S               ;5                                  restore W,T,S: R-- IP sign BASE
1979             JMP S15Q16LOOP          ;2                                  W=cnt
1980 S15Q16EOC   MOV 4(PSP),2(PSP)       ;5 -- addr ud2lo ud2lo uqlo x       ud2lo from >NUMBER part1 becomes here ud2hi=S15 part2
1981             MOV @PSP,4(PSP)         ;4 -- addr ud2lo ud2hi x x          uqlo becomes ud2lo
1982             MOV T,TOS               ;1 -- addr ud2lo ud2hi x cnt2
1983             CMP.B #0,TOS            ;1                                  TOS = 0 if end of conversion char = ',' (happy end)
1984         .ENDIF
1985 ; ----------------------------------;97
1986 QNUMNEXT    POPM #3,IP              ;4 -- addr ud2lo-hi x cnt2          POPM T,S,IP   S = sign flag = {-1;0}
1987             MOV S,TOS               ;1 -- addr ud2lo-hi x sign
1988             MOV T,&BASE             ;3
1989             JZ QNUMOK               ;2 -- addr ud2lo-hi x sign          conversion OK
1990 QNUMKO
1991         .IFDEF DOUBLE_NUMBERS
1992             BIC #UF9,SR
1993         .ENDIF
1994             ADD #6,PSP              ;1 -- addr sign
1995             AND #0,TOS              ;1 -- addr ff                       TOS=0 and Z=1 ==> conversion ko
1996             mNEXT                   ;4
1997 ; ----------------------------------;
1998         .IFDEF DOUBLE_NUMBERS
1999 QNUMOK      ADD #2,PSP              ;1 -- addr ud2lo ud2hi sign
2000             MOV 2(PSP),4(PSP)       ;  -- udlo udlo udhi sign
2001             MOV @PSP+,0(PSP)        ;4 -- udlo udhi sign                note : PSP is incremented before write back !!!
2002             XOR #-1,TOS             ;1 -- udlo udhi inv(sign)
2003             JNZ QDOUBLE             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
2004 Q2NEGATE    XOR #-1,TOS             ;1 -- udlo udhi tf
2005             XOR #-1,2(PSP)          ;3
2006             XOR #-1,0(PSP)          ;3
2007             ADD #1,2(PSP)           ;3
2008             ADDC #0,0(PSP)          ;3 -- dlo dhi tf
2009 QDOUBLE     BIT #UF9,SR             ;2 -- dlo dhi tf                decimal point added ?
2010             JNZ QNUMEND             ;2 -- dlo dhi tf                leave double
2011             ADD #2,PSP              ;1 -- dlo tf                    leave number, Z=0
2012 QNUMEND     mNEXT                   ;4                              TOS=-1 and Z=0 ==> conversion ok
2013         .ELSE
2014 QNUMOK      ADD #4,PSP              ;1 -- addr ud2lo sign
2015             MOV @PSP+,0(PSP)        ;4 -- udlo sign                note : PSP is incremented before write back !!!
2016             XOR #-1,TOS             ;1 -- udlo udhi inv(sign)
2017             JNZ QNUMEND             ;2                                  if jump : TOS=-1 and Z=0 ==> conversion ok
2018 QNEGATE     XOR #-1,0(PSP)          ;3
2019             ADD #1,0(PSP)           ;3 -- n tf
2020             XOR #-1,TOS             ;1 -- udlo udhi tf              TOS=-1 and Z=0
2021 QNUMEND     mNEXT                   ;4                              TOS=-1 and Z=0 ==> conversion ok
2022         .ENDIF ; DOUBLE_NUMBERS
2023 ; ----------------------------------;128 words
2024     .ENDIF ; of Hardware/Software MPY
2025
2026 ;https://forth-standard.org/standard/core/EXECUTE
2027 ;C EXECUTE   i*x xt -- j*x   execute Forth word at 'xt'
2028             FORTHWORD "EXECUTE"
2029 EXECUTE     MOV TOS,W               ; 1 put word address into W
2030             MOV @PSP+,TOS           ; 2 fetch new TOS
2031             MOV W,PC                ; 3 fetch code address into PC
2032
2033 ;https://forth-standard.org/standard/core/Comma
2034 ;C ,    x --           append cell to dict
2035             FORTHWORD ","
2036 COMMA       MOV &DDP,W              ;3
2037             ADD #2,&DDP             ;3
2038             MOV TOS,0(W)            ;3
2039             MOV @PSP+,TOS           ;2
2040             mNEXT                   ;4 15~
2041
2042     .IFDEF DOUBLE_NUMBERS           ; are recognized
2043 ;https://forth-standard.org/standard/core/LITERAL
2044 ;C LITERAL  n --        append single numeric literal if compiling state
2045 ;           d --        append double numeric literal if compiling state and if UF9<>0 (not ANS)
2046             FORTHWORDIMM "LITERAL"  ; immediate
2047 LITERAL     CMP #0,&STATE           ;3
2048             JZ LITERAL2             ;2 if not immediate, clear UF9 flag, leave n|d on the stack
2049 LITERAL1    MOV &DDP,W              ;3
2050             ADD #4,&DDP             ;3
2051             MOV #lit,0(W)           ;4
2052             MOV TOS,2(W)            ;3
2053             MOV @PSP+,TOS           ;2
2054             BIT #UF9,SR             ;2
2055 LITERAL2    BIC #UF9,SR             ;2
2056             JZ LITERALEND           ;2
2057             MOV 2(W),X              ;3
2058             MOV TOS,2(W)            ;3
2059             MOV X,TOS               ;1
2060             JMP LITERAL1            ;2
2061 LITERALEND  mNEXT                   ;4
2062
2063     .ELSE
2064 ;https://forth-standard.org/standard/core/LITERAL
2065 ;C LITERAL  n --        append single numeric literal if compiling state
2066             FORTHWORDIMM "LITERAL"  ; immediate
2067 LITERAL     CMP #0,&STATE           ;3
2068             JZ LITERALEND           ;2 if not immediate, leave n|d on the stack
2069 LITERAL1    MOV &DDP,W              ;3
2070             ADD #4,&DDP             ;3
2071             MOV #lit,0(W)           ;4
2072             MOV TOS,2(W)            ;3
2073             MOV @PSP+,TOS           ;2
2074 LITERALEND  mNEXT                   ;4
2075     .ENDIF
2076
2077 ;https://forth-standard.org/standard/core/COUNT
2078 ;C COUNT   c-addr1 -- adr len   counted->adr/len
2079             FORTHWORD "COUNT"
2080 COUNT       SUB #2,PSP              ;1
2081             ADD #1,TOS              ;1
2082             MOV TOS,0(PSP)          ;3
2083             MOV.B -1(TOS),TOS       ;3
2084             mNEXT                   ;4 15~
2085
2086 ; : SETIB SOURCE 2! 0 >IN ! ;       ; org len --        set Input Buffer, shared by INTERPRET and [ELSE]
2087 SETIB       MOV TOS,&SOURCE_LEN     ; -- org len
2088             MOV @PSP+,&SOURCE_ADR   ; -- len
2089             MOV @PSP+,TOS           ; --
2090             MOV #0,&TOIN            ;
2091             mNEXT                   ;
2092
2093 ;C INTERPRET    i*x -- j*x      interpret given buffer
2094 ; This is the common factor of EVALUATE and QUIT.
2095 ; set addr u as input buffer then parse it word by word
2096 INTERPRET   mDOCOL                  ;
2097 INTLOOP     .word   FBLANK,WORDD    ; -- c-addr     Z = End Of Line
2098             FORTHtoASM              ;
2099             MOV #INTFINDNEXT,IP     ;2              define INTFINDNEXT as FIND return
2100             JNZ FIND                ;2              Z=0, EOL not reached
2101             JMP DROPEXIT            ;               Z=1, EOL reached
2102
2103 INTFINDNEXT FORTHtoASM              ; -- c-addr fl  Z = not found
2104             MOV TOS,W               ;               W = flag =(-1|0|+1)  as (normal|not_found|immediate)
2105             MOV @PSP+,TOS           ; -- c-addr
2106             MOV #INTQNUMNEXT,IP     ;2              define QNUMBER return
2107             JZ QNUMBER              ;2 c-addr --    Z=1, not found, search a number
2108             MOV #INTLOOP,IP         ;2              define (EXECUTE | COMMA) return
2109             XOR &STATE,W            ;3
2110             JZ COMMA                ;2 c-addr --    if W xor STATE = 0 compile xt then loop back to INTLOOP
2111             JNZ EXECUTE             ;2 c-addr --    if W xor STATE <>0 execute xt then loop back to INTLOOP
2112
2113 INTQNUMNEXT FORTHtoASM              ;  -- n|c-addr fl   Z = not a number, SR(UF9) double number request
2114             MOV @PSP+,TOS           ;2
2115             MOV #INTLOOP,IP         ;2 -- n|c-addr  define LITERAL return
2116             JNZ LITERAL             ;2 n --         Z=0, is a number, execute LITERAL then loop back to INTLOOP
2117 NotFoundExe ADD.B #1,0(TOS)         ;3 c-addr --    Z=1, Not a Number : incr string count to add '?'
2118             MOV.B @TOS,Y            ;2              Y=count+1
2119             ADD TOS,Y               ;1              Y=end of string addr
2120             MOV.B #'?',0(Y)         ;5              add '?' to end of string
2121             MOV #FQABORTYES,IP      ;2              define COUNT return
2122             JMP COUNT               ;2 -- addr len  36 words
2123
2124 ;https://forth-standard.org/standard/core/EVALUATE
2125 ; EVALUATE          \ i*x c-addr u -- j*x  interpret string
2126             FORTHWORD "EVALUATE"
2127 EVALUATE    MOV #SOURCE_LEN,X       ;2
2128             MOV @X+,S               ;2 S = SOURCE_LEN
2129             MOV @X+,T               ;2 T = SOURCE_ADR
2130             MOV @X+,W               ;2 W = TOIN
2131             PUSHM #4,IP             ;6 PUSHM IP,S,T,W
2132             ASMtoFORTH
2133             .word   SETIB,INTERPRET
2134             FORTHtoASM
2135             MOV @RSP+,&TOIN         ;4
2136             MOV @RSP+,&SOURCE_ADR   ;4
2137             MOV @RSP+,&SOURCE_LEN   ;4
2138             mSEMI
2139
2140     .IFDEF DEFER_QUIT               ; defined in ThingsInFirst.inc
2141
2142 QUIT0   MOV #0,&SAVE_SYSRSTIV       ; clear SAVE_SYSRSTIV, usefull for next ABORT...
2143         MOV #RSTACK,RSP             ; ANS mandatory for QUIT
2144         MOV #LSTACK,&LEAVEPTR       ;
2145         MOV #0,&STATE               ; ANS mandatory for QUIT
2146         mNEXT
2147
2148 ;c BOOT  --  load BOOT.4th file from SD_Card then loop to QUIT1
2149         FORTHWORD "BOOT"
2150     CMP #0,&SAVE_SYSRSTIV           ; = 0 if WARM
2151     JZ BODYQUIT                     ; no boostrap if no reset event, default QUIT instead
2152     BIT.B #SD_CD,&SD_CDIN           ; SD_memory in SD_Card module ?
2153     JNZ BODYQUIT                    ; if not, no bootstrap, default QUIT instead
2154     SUB #2,PSP                      ;
2155     MOV TOS,0(PSP)                  ;
2156     MOV &SAVE_SYSRSTIV,TOS          ; -- SAVE_SYSRSTIV      TOS = reset event, for tests in BOOT.4TH
2157     ASMtoFORTH                      ;
2158     .word NOECHO                    ; warning ! your BOOT.4TH must to be finished with ECHO command!
2159     .word QUIT0                     ;
2160     .word XSQUOTE                   ; -- addr u
2161     .byte 15,"LOAD\34 BOOT.4TH\34"  ; LOAD" BOOT.4TH" issues error 2 if no such file...
2162     .word BRAN,QUIT4                ; to interpret this string
2163 ; ----------------------------------;
2164
2165 ;https://forth-standard.org/standard/core/QUIT
2166 ;c QUIT  --     interpret line by line the input stream, primary DEFERred word
2167 ; to enable bootstrap type: ' BOOT IS QUIT
2168 ; to disable bootstrap type: ' QUIT >BODY IS QUIT
2169
2170         FORTHWORD "QUIT"
2171 QUIT        MOV @PC+,PC             ;3 Code Field Address (CFA) of QUIT
2172 PFAQUIT     .word   BODYQUIT        ;  Parameter Field Address (PFA) of QUIT
2173 BODYQUIT    ASMtoFORTH              ;  BODY of QUIT = default execution of QUIT
2174             .word   QUIT0           ;
2175
2176     .ELSE ; if no BOOTLOADER, QUIT is not DEFERred
2177
2178 ;https://forth-standard.org/standard/core/QUIT
2179 ;c QUIT  --     interpret line by line the input stream
2180         FORTHWORD "QUIT"
2181 QUIT
2182 QUIT0       MOV #0,&SAVE_SYSRSTIV   ; clear SAVE_SYSRSTIV, usefull for next ABORT...
2183             MOV #RSTACK,RSP         ; ANS mandatory for QUIT
2184             MOV #LSTACK,&LEAVEPTR   ;
2185             MOV #0,&STATE           ; ANS mandatory for QUIT
2186             ASMtoFORTH              ;
2187
2188     .ENDIF ; bootloader
2189
2190     .IFDEF PROMPT
2191 QUIT1       .word   XSQUOTE         ;
2192             .byte   5,13,10,"ok "   ; CR+LF + Forth prompt
2193 QUIT2       .word   TYPE            ; display it
2194     .ELSE
2195 QUIT2       .word   CR
2196     .ENDIF
2197             .word   REFILL          ; -- org len      refill input buffer from ACCEPT (one line)
2198 QUIT3       .word   SPACE           ;
2199 QUIT4       .word   SETIB           ; --
2200 QUIT5       .word   INTERPRET       ; interpret this line
2201             .word   DEPTH,ZEROLESS  ; stack empty test
2202             .word   XSQUOTE         ; ABORT" stack empty! "
2203             .byte 13,"stack empty! ";
2204             .word   QABORT          ;
2205             .word   lit,FRAM_FULL,HERE,ULESS ; FRAM full test
2206             .word   XSQUOTE         ; ABORT" FRAM full! "
2207             .byte   11,"FRAM full! ";
2208             .word   QABORT          ;
2209     .IFDEF PROMPT
2210             .word   FSTATE,FETCH    ; STATE @
2211             .word   QFBRAN,QUIT1    ; 0= case of interpretion state
2212             .word   XSQUOTE         ; 0<> case of compilation state
2213             .byte   5,13,10,"   "   ; CR+LF + 3 spaces
2214     .ENDIF
2215             .word   BRAN,QUIT2
2216
2217 ;https://forth-standard.org/standard/core/ABORT
2218 ;C ABORT    i*x --   R: j*x --   clear stack & QUIT
2219             FORTHWORD "ABORT"
2220 ABORT       MOV #PSTACK,PSP
2221             JMP QUIT
2222
2223 ;https://forth-standard.org/standard/core/ABORTq
2224 ;C ABORT"  i*x flag -- i*x   R: j*x -- j*x  flag=0
2225 ;C         i*x flag --       R: j*x --      flag<>0
2226             FORTHWORDIMM "ABORT\34" ; immediate
2227 ABORTQUOTE  mDOCOL                  ; ABORT address + 10
2228             .word   SQUOTE
2229             .word   lit,QABORT,COMMA
2230             .word   EXIT
2231
2232 ; define run-time part of ABORT"
2233 ;Z ?ABORT   f c-addr u --      abort & print msg,
2234 ;            FORTHWORD "?ABORT"
2235 QABORT      CMP #0,2(PSP)           ; -- f c-addr u         flag test
2236             JNZ QABORTYES           ;
2237 THREEDROP   ADD #4,PSP              ;
2238             MOV @PSP+,TOS           ;
2239             mNEXT                   ;
2240 ; ----------------------------------; QABORTYES = QABORT + 14
2241 QABORTYES   CALL #QAB_DEFER         ; init some variables, see WIPE
2242 ; ----------------------------------;
2243 QABORT_SDCARD                       ; close all handles
2244 ; ----------------------------------;
2245     .IFDEF SD_CARD_LOADER           ;
2246             MOV &CurrentHdl,T       ;
2247 QABORTCLOSE CMP #0,T                ;
2248             JZ QABORTCLOSEND        ;
2249             MOV.B #0,HDLB_Token(T)  ;
2250             MOV @T,T                ;
2251             JMP QABORTCLOSE         ;
2252 QABORTCLOSEND                       ;
2253     .ENDIF                          ;
2254 ; ----------------------------------;
2255 QABORT_TERM                         ; wait the end of downloading source file
2256 ; ----------------------------------;
2257             CALL #RXON              ; send XON and/or set RTS low
2258 QABORTLOOP  BIC #UCRXIFG,&TERM_IFG  ; clear UCRXIFG
2259         MOV #int(frequency*2730),Y  ; 2730*frequency ==> 65520 @ 24MHz
2260 QABUSBLOOPJ MOV #8,X                ; 1~        <-------+ windows 10 seems very slow... ==> 2730*36 = 98ms delay
2261             ADD X,X                 ; 1~                | linux seems very very slow... ==> 2730*69 = 188ms delay
2262 QABUSBLOOPI NOP                     ; 1~        <---+   |
2263             SUB #1,X                ; 1~            |   |
2264             JNZ QABUSBLOOPI         ; 2~ 4~ loop ---+   |
2265             SUB #1,Y                ; 1~                |
2266             JNZ QABUSBLOOPJ         ; 2~ 36~/69~ loop --+
2267             BIT #UCRXIFG,&TERM_IFG  ; 4 new char in TERMRXBUF after delay for OS refill ?
2268             JNZ QABORTLOOP          ; 2 yes, the input stream is still active: loop back
2269 ; ----------------------------------;
2270             mDOCOL                  ;
2271             .word   PWR_STATE       ; remove all words beyond PWR_HERE, including a definition leading to an error
2272             .word   ECHO
2273 ; ----------------------------------;
2274 ; Display ABORT" message            ; <== WARM jumps here
2275 ; ----------------------------------;
2276 QABORT_DISPLAY                      ;
2277             .word   lit,LINE,FETCH  ;
2278             .word   XSQUOTE         ; -- c-addr u c-addr1 u1
2279             .byte   4,27,"[7m"      ;    type ESC[7m
2280             .word   TYPE            ; -- c-addr u       set reverse video
2281             .word   QDUP            ;       if LINE <> 0
2282             .word QFBRAN,ERRLINE_END;       if LINE = 0
2283 ERRLINE     .word   XSQUOTE         ;       else displays the line where error occured
2284             .byte   5,"line:"       ;
2285             .word   TYPE            ;
2286             .word   ONEMINUS        ;
2287             .word   UDOT            ;
2288 ERRLINE_END .word   TYPE            ; --                type abort message
2289             .word   XSQUOTE         ; -- c-addr2 u2
2290             .byte   4,27,"[0m"      ;
2291             .word   TYPE            ; --                set normal video
2292 FABORT      .word   ABORT           ; no return; FABORT = BRACTICK-8
2293 ; ----------------------------------;
2294
2295 ;-------------------------------------------------------------------------------
2296 ; COMPILER
2297 ;-------------------------------------------------------------------------------
2298
2299 ;https://forth-standard.org/standard/core/BracketTick
2300 ;C ['] <name>        --         find word & compile it as literal
2301             FORTHWORDIMM "[']"      ; immediate word, i.e. word executed during compilation
2302 BRACTICK    mDOCOL
2303             .word   TICK            ; get xt of <name>
2304             .word   lit,lit,COMMA   ; append LIT action
2305             .word   COMMA,EXIT      ; append xt literal
2306
2307 ;https://forth-standard.org/standard/core/Tick
2308 ;C '    -- xt           find word in dictionary and leave on stack its execution address
2309             FORTHWORD "'"
2310 TICK        mDOCOL          ; separator -- xt
2311             .word   FBLANK,WORDD,FIND    ; Z=1 if not found
2312             .word   QFBRAN,NotFound
2313             .word   EXIT
2314 NotFound    .word   NotFoundExe          ; in INTERPRET
2315
2316 ;https://forth-standard.org/standard/block/bs
2317 ; \         --      backslash
2318 ; everything up to the end of the current line is a comment.
2319             FORTHWORDIMM "\\"       ; immediate
2320 BACKSLASH   MOV &SOURCE_LEN,&TOIN   ;
2321             mNEXT
2322
2323 ;https://forth-standard.org/standard/core/Bracket
2324 ;C [        --      enter interpretative state
2325                 FORTHWORDIMM "["    ; immediate
2326 LEFTBRACKET     MOV #0,&STATE
2327                 mNEXT
2328
2329 ;https://forth-standard.org/standard/core/right-bracket
2330 ;C ]        --      enter compiling state
2331                 FORTHWORD "]"
2332 RIGHTBRACKET    MOV  #-1,&STATE
2333                 mNEXT
2334
2335 ;https://forth-standard.org/standard/core/DEFERStore
2336 ;C DEFER!       xt CFA_DEFER --     ; store xt into the PFA of DEFERed word
2337 ;                FORTHWORD "DEFER!"
2338 DEFERSTORE  MOV @PSP+,2(TOS)        ; -- CFA_DEFER          xt --> [CFA_DEFER+2]
2339             MOV @PSP+,TOS           ; --
2340             mNEXT
2341
2342 ;https://forth-standard.org/standard/core/IS
2343 ;C IS <name>        xt --
2344 ; used as is :
2345 ; DEFER DISPLAY                         create a "do nothing" definition (2 CELLS)
2346 ; inline command : ' U. IS DISPLAY      U. becomes the runtime of the word DISPLAY
2347 ; or in a definition : ... ['] U. IS DISPLAY ...
2348 ; KEY, EMIT, CR, ACCEPT and WARM are examples of DEFERred words
2349
2350 ; as IS replaces the PFA value of any word, it may be also used as TO for VARIABLE and CONSTANT words...
2351
2352             FORTHWORDIMM "IS"       ; immediate
2353 IS          mDOCOL
2354             .word   FSTATE,FETCH        ; STATE @
2355             .word   QFBRAN,IS_EXEC      ; if = 0
2356 IS_COMPILE  .word   BRACTICK            ; find the word, compile its CFA as literal
2357             .word   lit,DEFERSTORE,COMMA; compile DEFERSTORE
2358             .word   EXIT                ;
2359 IS_EXEC     .word   TICK,DEFERSTORE     ; find the word, leave its CFA on the stack and
2360             .word   EXIT                ; put it into PFA of DEFERed word, then exit.
2361
2362 ;https://forth-standard.org/standard/core/IMMEDIATE
2363 ;C IMMEDIATE        --   make last definition immediate
2364             FORTHWORD "IMMEDIATE"
2365 IMMEDIATE   MOV &LAST_NFA,W
2366             BIS.B #80h,0(W)
2367             mNEXT
2368
2369 ;https://forth-standard.org/standard/core/RECURSE
2370 ;C RECURSE  --      recurse to current definition (compile current definition)
2371             FORTHWORDIMM "RECURSE"  ; immediate
2372 RECURSE     MOV &DDP,X              ;
2373             MOV &LAST_CFA,0(X)      ;
2374             ADD #2,&DDP             ;
2375             mNEXT
2376
2377 ;https://forth-standard.org/standard/core/POSTPONE
2378             FORTHWORDIMM "POSTPONE" ; immediate
2379 POSTPONE    mDOCOL
2380             .word   FBLANK,WORDD,FIND,QDUP
2381             .word   QFBRAN,NotFound
2382             .word   ZEROLESS        ; immediate word ?
2383             .word   QFBRAN,POST1    ; if immediate
2384             .word   lit,lit,COMMA   ; else  compile lit
2385             .word   COMMA           ;       compile xt
2386             .word   lit,COMMA       ;       CFA of COMMA
2387 POST1       .word   COMMA,EXIT      ; then compile: if immediate xt of word found else CFA of COMMA
2388
2389 ;https://forth-standard.org/standard/core/Semi
2390 ;C ;            --      end a colon definition
2391             FORTHWORDIMM ";"        ; immediate
2392 SEMICOLON   CMP #0,&STATE           ; if interpret mode, semicolon becomes a comment separator
2393             JZ BACKSLASH            ; tip: ";" is transparent to the preprocessor, so semicolon comments are kept in file.4th
2394             mDOCOL                  ; compile mode
2395             .word   lit,EXIT,COMMA
2396             .word   QREVEAL,LEFTBRACKET,EXIT
2397
2398     .IFDEF NONAME
2399 ;https://forth-standard.org/standard/core/ColonNONAME
2400 ;CE :NONAME        -- xt
2401         FORTHWORD ":NONAME"
2402 COLONNONAME SUB #2,PSP
2403             MOV TOS,0(PSP)
2404             MOV &DDP,TOS            ; -- xt     of this NONAME word
2405             MOV TOS,W               ;  W=CFA
2406             MOV #PAIN,X             ;2 MOV Y,0(X) writes to PAIN read only register = first lure for semicolon REVEAL...
2407             MOV #PAOUT,Y            ;2 MOV @X,-2(Y) writes to PAIN register = 2th lure for semicolon REVEAL...
2408             CALL #HEADEREND         ; ...because we don't want write a preamble of word in dictionnary!
2409     .ENDIF ; NONAME
2410
2411 ;-----------------------------------; common part of NONAME and :
2412 COLONNEXT
2413     .SWITCH DTC
2414     .CASE 1
2415             MOV #DOCOL1,-4(W)       ; compile CALL rDOCOL
2416             SUB #2,&DDP
2417     .CASE 2
2418             MOV #DOCOL1,-4(W)       ; compile PUSH IP       3~
2419             MOV #DOCOL2,-2(W)       ; compile CALL rEXIT
2420     .CASE 3 ; inlined DOCOL
2421             MOV #DOCOL1,-4(W)       ; compile PUSH IP       3~
2422             MOV #DOCOL2,-2(W)       ; compile MOV PC,IP     1~
2423             MOV #DOCOL3,0(W)        ; compile ADD #4,IP     1~
2424             MOV #NEXT,+2(W)         ; compile MOV @IP+,PC   4~
2425             ADD #4,&DDP
2426     .ENDCASE ; of DTC
2427             MOV #-1,&STATE          ; enter compiling state
2428 SAVE_PSP    MOV PSP,&LAST_PSP       ; save PSP for check compiling, used by QREVEAL
2429 NEXT_ADR    mNEXT
2430 ;-----------------------------------;
2431
2432
2433 ;https://forth-standard.org/standard/core/Colon
2434 ;C : <name>     --      begin a colon definition
2435             FORTHWORD ":"
2436 COLON       PUSH #COLONNEXT         ; define COLONNEXT as RET from HEADER
2437
2438 ; HEADER        create an header for a new word. Max count of chars = 126
2439 ;               common code for DEFER, VARIABLE, CONSTANT, CREATE, :, MARKER, CODE, ASM.
2440 ;               doesn't link the created word in vocabulary.
2441 HEADER      mDOCOL
2442             .word CELLPLUSALIGN     ;               align and make room for LFA
2443             .word FBLANK,WORDD      ;
2444             FORTHtoASM              ; -- HERE       HERE is the NFA of this new word
2445             MOV @RSP+,IP
2446             MOV TOS,Y               ; -- NFA        Y=NFA
2447             MOV.B @TOS+,W           ; -- NFA+1      W=Count_of_chars
2448             BIS.B #1,W              ;               W=count is always odd
2449             ADD.B #1,W              ;               W=add one byte for length
2450             ADD Y,W                 ;               W=Aligned_CFA
2451             MOV &CURRENT,X          ;               X=VOC_BODY of CURRENT
2452     .SWITCH THREADS
2453     .CASE   1                       ;               nothing to do
2454     .ELSECASE                       ;               multithreading add 5~ 4words
2455             MOV.B @TOS,TOS          ; -- char       TOS=first CHAR of new word
2456             AND #(THREADS-1)*2,TOS  ; -- offset     TOS= Thread offset
2457             ADD TOS,X               ;               X=VOC_PFAx = thread x of VOC_PFA of CURRENT
2458     .ENDCASE
2459             MOV @PSP+,TOS           ; --
2460             MOV #4030h,0(W)         ;               by default, HEADER create a DEFERred word: CFA = MOV @PC+,PC = BR mNEXT
2461             MOV #NEXT_ADR,2(W)      ;               by default, HEADER create a DEFERred word: PFA = address of mNEXT to do nothing.
2462
2463 HEADEREND   MOV Y,&LAST_NFA         ;               NFA --> LAST_NFA            used by QREVEAL, IMMEDIATE, MARKER
2464             MOV X,&LAST_THREAD      ;               VOC_PFAx --> LAST_THREAD    used by QREVEAL
2465             MOV W,&LAST_CFA         ;               HERE=CFA --> LAST_CFA       used by DOES>, RECURSE
2466             ADD #4,W                ;               by default make room for two words...
2467             MOV W,&DDP              ;
2468             RET                     ; 30 words, W is the new DDP value )
2469                                     ;           X is LAST_THREAD       > used by VARIABLE, CONSTANT, CREATE, DEFER and :
2470                                     ;           Y is NFA               )
2471
2472 ;;Z ?REVEAL   --      if no stack mismatch, link this new word in the CURRENT vocabulary
2473 ;            FORTHWORD "REVEAL"     ; used by SEMICOLON and ENDCODE
2474 QREVEAL     CMP PSP,&LAST_PSP       ; Check SP with its saved value by :
2475             JNZ BAD_CSP             ; if no stack mismatch.
2476 GOOD_CSP    MOV &LAST_NFA,Y         ; GOOD_CSP is the end of word MARKER
2477             MOV &LAST_THREAD,X      ;
2478 REVEAL      MOV @X,-2(Y)            ; [LAST_THREAD] --> LFA    (for NONAME: [LAST_THREAD] --> PAIN)
2479             MOV Y,0(X)              ; LAST_NFA --> [LAST_THREAD]    (for NONAME: LAST_NFA --> PAIN)
2480             mNEXT
2481
2482 BAD_CSP     mDOCOL
2483             .word   XSQUOTE
2484             .byte   15,"stack mismatch!"
2485 FQABORTYES  .word   QABORTYES
2486
2487 ;https://forth-standard.org/standard/core/VARIABLE
2488 ;C VARIABLE <name>       --                      define a Forth VARIABLE
2489             FORTHWORD "VARIABLE"
2490 VARIABLE    CALL #HEADER            ; W = DDP = CFA + 2 words
2491             MOV #DOVAR,-4(W)        ;   CFA = DOVAR, PFA is undefined
2492             JMP REVEAL              ;   to link created VARIABLE in vocabulary
2493
2494 ;https://forth-standard.org/standard/core/CONSTANT
2495 ;C CONSTANT <name>     n --                      define a Forth CONSTANT (and also a Forth VALUE)
2496             FORTHWORD "CONSTANT"
2497 CONSTANT    CALL #HEADER            ; W = DDP = CFA + 2 words
2498             MOV #DOCON,-4(W)        ;   CFA = DOCON
2499             MOV TOS,-2(W)           ;   PFA = n
2500             MOV @PSP+,TOS
2501             JMP REVEAL              ;   to link created VARIABLE in vocabulary
2502
2503 ;;https://forth-standard.org/standard/core/VALUE
2504 ;;( x "<spaces>name" -- )                      define a Forth VALUE
2505 ;;Skip leading space delimiters. Parse name delimited by a space.
2506 ;;Create a definition for name with the execution semantics defined below,
2507 ;;with an initial value equal to x.
2508 ;
2509 ;;name Execution: ( -- x )
2510 ;;Place x on the stack. The value of x is that given when name was created,
2511 ;;until the phrase x TO name is executed, causing a new value of x to be assigned to name.
2512 ;
2513 ;            FORTHWORD "VALUE"       ; VALUE is an alias of CONSTANT
2514 ;            JMP CONSTANT
2515 ;
2516 ;;TO name Run-time: ( x -- )
2517 ;;Assign the value x to name.
2518 ;
2519 ;            FORTHWORDIMM "TO"       ; TO is an alias of IS
2520 ;            JMP IS
2521
2522 ; usage : SDIB_ORG IS CIB           ; modify Current_Input_Buffer address to read a SD file sector
2523 ;         ...
2524 ;         TIB_ORG IS CIB            ; restore Terminal_Input_Buffer address as Current_Input_Buffer address
2525
2526 ;https://forth-standard.org/standard/core/CREATE
2527 ;C CREATE <name>        --          define a CONSTANT with its next address
2528 ; Execution: ( -- a-addr )          ; a-addr is the address of name's data field
2529 ;                                   ; the execution semantics of name may be extended by using DOES>
2530             FORTHWORD "CREATE"
2531 CREATE      CALL #HEADER            ; --        W = DDP
2532             MOV #DOCON,-4(W)        ;4  -4(W) = CFA = DOCON
2533             MOV W,-2(W)             ;3  -2(W) = PFA = W = next address
2534             JMP REVEAL              ;   to link created VARIABLE in vocabulary
2535
2536 ;https://forth-standard.org/standard/core/DOES
2537 ;C DOES>    --          set action for the latest CREATEd definition
2538             FORTHWORD "DOES>"
2539 DOES        MOV &LAST_CFA,W         ; W = CFA of CREATEd word
2540             MOV #DODOES,0(W)        ; replace CFA (DOCON) by new CFA (DODOES)
2541             MOV IP,2(W)             ; replace PFA by the address after DOES> as execution address
2542             mSEMI                   ; exit of the new created word
2543
2544 ;https://forth-standard.org/standard/core/DEFER
2545 ;C DEFER "<spaces>name"   --
2546 ;Skip leading space delimiters. Parse name delimited by a space.
2547 ;Create a definition for name with the execution semantics defined below.
2548
2549 ;name Execution:   --
2550 ;Execute the xt that name is set to execute, i.e. NEXT (nothing),
2551 ;until the phrase ' word IS name is executed, causing a new value of xt to be assigned to name.
2552
2553             FORTHWORD "DEFER"
2554 DEFER       PUSH #REVEAL        ; to link created DEFER word in vocabulary
2555             JMP HEADER          ; that create a secondary DEFERed word (whithout default code)
2556
2557 ;https://forth-standard.org/standard/core/toBODY
2558 ; >BODY     -- addr      leave BODY of a CREATEd word or of a primary DEFERred word
2559             FORTHWORD ">BODY"
2560             ADD #4,TOS
2561             mNEXT
2562
2563     .IFDEF MSP430ASSEMBLER
2564
2565            FORTHWORD "CODE"     ; a CODE word must be finished with ENDCODE
2566 ASMCODE     CALL #HEADER        ;
2567 ASMCODE1    SUB #4,W            ; W = CFA
2568             MOV W,&DDP          ; CFA --> DDP
2569             mDOCOL
2570             .word   SAVE_PSP
2571             .word   ALSO,ASSEMBLER
2572             .word   EXIT
2573
2574     .IFDEF NONAME
2575             FORTHWORD "CODENNM"  ; CODENoNaMe is the assembly counterpart of :NONAME
2576 CODENNM     mDOCOL
2577             .word COLONNONAME,LEFTBRACKET
2578             .word ASMCODE1,EXIT
2579     .ENDIF
2580
2581             asmword "ENDCODE"   ; restore previous context and test PSP balancing
2582 ENDCODE     mDOCOL
2583             .word   PREVIOUS,QREVEAL
2584             .word   EXIT
2585
2586 ; ASM and ENDASM are used to define an assembler word which is not executable by FORTH interpreter
2587 ; i.e. typically an assembler word called by CALL and ended by RET, or an interrupt routine ended by RETI.
2588 ; ASM words are only usable in another ASSEMBLER words
2589 ; any ASM word must be finished with ENDASM.
2590 ; The template " ASM ... COLON ... ; " or any other finishing by SEMICOLON is
2591 ; prohibited because it doesn't restore CURRENT.
2592
2593             FORTHWORD "ASM"
2594             MOV     &CURRENT,&SAV_CURRENT
2595             MOV     #BODYASSEMBLER,&CURRENT
2596             JMP     ASMCODE
2597
2598             asmword "ENDASM"    ; end of an ASM word
2599             MOV     &SAV_CURRENT,&CURRENT
2600             JMP     ENDCODE
2601
2602
2603 ; here are words used to switch from/to FORTH to/from ASSEMBLER
2604
2605             asmword "COLON"     ; compile DOCOL, remove ASSEMBLER from CONTEXT, switch to compilation state
2606             MOV &DDP,W
2607     .SWITCH DTC
2608     .CASE 1
2609             MOV #DOCOL1,0(W)    ; compile CALL xDOCOL
2610             ADD #2,&DDP
2611
2612     .CASE 2
2613             MOV #DOCOL1,0(W)    ; compile PUSH IP
2614 COLON1      MOV #DOCOL2,2(W)    ; compile CALL rEXIT
2615             ADD #4,&DDP
2616
2617     .CASE 3 ; inlined DOCOL
2618             MOV #DOCOL1,0(W)    ; compile PUSH IP
2619 COLON1      MOV #DOCOL2,2(W)    ; compile MOV PC,IP
2620             MOV #DOCOL3,4(W)    ; compile ADD #4,IP
2621             MOV #NEXT,6(W)      ; compile MOV @IP+,PC
2622             ADD #8,&DDP         ;
2623     .ENDCASE ; DTC
2624
2625 COLON2      MOV #-1,&STATE      ; enter in compile state
2626             MOV #PREVIOUS,PC    ; restore previous state of CONTEXT
2627
2628
2629             asmword "LO2HI"     ; same as COLON but without saving IP
2630     .SWITCH DTC
2631     .CASE 1                     ; compile 2 words
2632             MOV &DDP,W
2633             MOV #12B0h,0(W)     ; compile CALL #EXIT, 2 words  4+6=10~
2634             MOV #EXIT,2(W)
2635             ADD #4,&DDP
2636             JMP COLON2
2637     .ELSECASE                   ; CASE 2 : compile 1 word, CASE 3 : compile 3 words
2638             SUB #2,&DDP         ; to skip PUSH IP
2639             MOV &DDP,W
2640             JMP COLON1
2641     .ENDCASE
2642
2643              FORTHWORDIMM "HI2LO"   ; immediate, switch to low level, add ASSEMBLER context, set interpretation state
2644             mDOCOL
2645 HI2LO       .word   HERE,CELLPLUS,COMMA
2646             .word   LEFTBRACKET
2647 HI2LONEXT   .word   ALSO,ASSEMBLER
2648             .word   EXIT
2649
2650     .ENDIF ; MSP430ASSEMBLER
2651
2652 ; ------------------------------------------------------------------------------
2653 ; CONTROL STRUCTURES
2654 ; ------------------------------------------------------------------------------
2655 ; THEN and BEGIN compile nothing
2656 ; DO compile one word
2657 ; IF, ELSE, AGAIN, UNTIL, WHILE, REPEAT, LOOP & +LOOP compile two words
2658 ; LEAVE compile three words
2659
2660 ;https://forth-standard.org/standard/core/IF
2661 ;C IF       -- IFadr    initialize conditional forward branch
2662             FORTHWORDIMM "IF"       ; immediate
2663 IFF         SUB #2,PSP              ;
2664             MOV TOS,0(PSP)          ;
2665             MOV &DDP,TOS            ; -- HERE
2666             ADD #4,&DDP             ;           compile one word, reserve one word
2667             MOV #QFBRAN,0(TOS)      ; -- HERE   compile QFBRAN
2668 CELLPLUS    ADD #2,TOS              ; -- HERE+2=IFadr
2669             mNEXT
2670
2671 ;https://forth-standard.org/standard/core/ELSE
2672 ;C ELSE     IFadr -- ELSEadr        resolve forward IF branch, leave ELSEadr on stack
2673             FORTHWORDIMM "ELSE"     ; immediate
2674 ELSS        ADD #4,&DDP             ; make room to compile two words
2675             MOV &DDP,W              ; W=HERE+4
2676             MOV #bran,-4(W)
2677             MOV W,0(TOS)            ; HERE+4 ==> [IFadr]
2678             SUB #2,W                ; HERE+2
2679             MOV W,TOS               ; -- ELSEadr
2680             mNEXT
2681
2682 ;https://forth-standard.org/standard/core/THEN
2683 ;C THEN     IFadr --                resolve forward branch
2684             FORTHWORDIMM "THEN"     ; immediate
2685 THEN        MOV &DDP,0(TOS)         ; -- IFadr
2686             MOV @PSP+,TOS           ; --
2687             mNEXT
2688
2689 ;https://forth-standard.org/standard/core/BEGIN
2690 ;C BEGIN    -- BEGINadr             initialize backward branch
2691             FORTHWORDIMM "BEGIN"    ; immediate
2692 BEGIN       MOV #HERE,PC            ; BR HERE
2693
2694 ;https://forth-standard.org/standard/core/UNTIL
2695 ;C UNTIL    BEGINadr --             resolve conditional backward branch
2696             FORTHWORDIMM "UNTIL"    ; immediate
2697 UNTIL       MOV #QFBRAN,X
2698 UNTIL1      ADD #4,&DDP             ; compile two words
2699             MOV &DDP,W              ; W = HERE
2700             MOV X,-4(W)             ; compile Bran or QFBRAN at HERE
2701             MOV TOS,-2(W)           ; compile bakcward adr at HERE+2
2702             MOV @PSP+,TOS
2703             mNEXT
2704
2705 ;https://forth-standard.org/standard/core/AGAIN
2706 ;X AGAIN    BEGINadr --             resolve uncondionnal backward branch
2707             FORTHWORDIMM "AGAIN"    ; immediate
2708 AGAIN       MOV #bran,X
2709             JMP UNTIL1
2710
2711 ;https://forth-standard.org/standard/core/WHILE
2712 ;C WHILE    BEGINadr -- WHILEadr BEGINadr
2713             FORTHWORDIMM "WHILE"    ; immediate
2714 WHILE       mDOCOL
2715             .word   IFF,SWAP,EXIT
2716
2717 ;https://forth-standard.org/standard/core/REPEAT
2718 ;C REPEAT   WHILEadr BEGINadr --     resolve WHILE loop
2719             FORTHWORDIMM "REPEAT"   ; immediate
2720 REPEAT      mDOCOL
2721             .word   AGAIN,THEN,EXIT
2722
2723 ;https://forth-standard.org/standard/core/DO
2724 ;C DO       -- DOadr   L: -- 0
2725             FORTHWORDIMM "DO"       ; immediate
2726 DO          SUB #2,PSP              ;
2727             MOV TOS,0(PSP)          ;
2728             ADD #2,&DDP             ;   make room to compile xdo
2729             MOV &DDP,TOS            ; -- HERE+2
2730             MOV #xdo,-2(TOS)        ;   compile xdo
2731             ADD #2,&LEAVEPTR        ; -- HERE+2     LEAVEPTR+2
2732             MOV &LEAVEPTR,W         ;
2733             MOV #0,0(W)             ; -- HERE+2     L-- 0
2734             mNEXT
2735
2736 ;https://forth-standard.org/standard/core/LOOP
2737 ;C LOOP    DOadr --         L-- an an-1 .. a1 0
2738             FORTHWORDIMM "LOOP"     ; immediate
2739 LOO         MOV #xloop,X
2740 LOOPNEXT    ADD #4,&DDP             ; make room to compile two words
2741             MOV &DDP,W
2742             MOV X,-4(W)             ; xloop --> HERE
2743             MOV TOS,-2(W)           ; DOadr --> HERE+2
2744 ; resolve all "leave" adr
2745 LEAVELOOP   MOV &LEAVEPTR,TOS       ; -- Adr of top LeaveStack cell
2746             SUB #2,&LEAVEPTR        ; --
2747             MOV @TOS,TOS            ; -- first LeaveStack value
2748             CMP #0,TOS              ; -- = value left by DO ?
2749             JZ LOOPEND
2750             MOV W,0(TOS)            ; move adr after loop as UNLOOP adr
2751             JMP LEAVELOOP
2752 LOOPEND     MOV @PSP+,TOS
2753             mNEXT
2754
2755 ;https://forth-standard.org/standard/core/PlusLOOP
2756 ;C +LOOP   adrs --   L-- an an-1 .. a1 0
2757             FORTHWORDIMM "+LOOP"    ; immediate
2758 PLUSLOOP    MOV #xploop,X
2759             JMP LOOPNEXT
2760
2761 ;https://forth-standard.org/standard/core/LEAVE
2762 ;C LEAVE    --    L: -- adrs
2763             FORTHWORDIMM "LEAVE"    ; immediate
2764 LEAV        MOV &DDP,W              ; compile three words
2765             MOV #UNLOOP,0(W)        ; [HERE] = UNLOOP
2766             MOV #BRAN,2(W)          ; [HERE+2] = BRAN
2767             ADD #6,&DDP             ; [HERE+4] = After LOOP adr
2768             ADD #2,&LEAVEPTR
2769             ADD #4,W
2770             MOV &LEAVEPTR,X
2771             MOV W,0(X)              ; leave HERE+4 on LEAVEPTR stack
2772             mNEXT
2773
2774 ;https://forth-standard.org/standard/core/MOVE
2775 ;C MOVE    addr1 addr2 u --     smart move
2776 ;             VERSION FOR 1 ADDRESS UNIT = 1 CHAR
2777             FORTHWORD "MOVE"
2778 MOVE        MOV TOS,W           ; 1
2779             MOV @PSP+,Y         ; dest adrs
2780             MOV @PSP+,X         ; src adrs
2781             MOV @PSP+,TOS       ; pop new TOS
2782             CMP #0,W
2783             JZ MOVE_X           ; already made !
2784             CMP X,Y             ; Y-X ; dst - src
2785             JZ MOVE_X           ; already made !
2786             JC MOVEUP           ; U>= if dst > src
2787 MOVEDOWN    MOV.B @X+,0(Y)      ; if X=src > Y=dst copy W bytes down
2788             ADD #1,Y
2789             SUB #1,W
2790             JNZ MOVEDOWN
2791             mNEXT
2792 MOVEUP      ADD W,Y             ; start at end
2793             ADD W,X
2794 MOVUP1      SUB #1,X
2795             SUB #1,Y
2796 MOVUP2      MOV.B @X,0(Y)       ; if X=src < Y=dst copy W bytes up
2797             SUB #1,W
2798             JNZ MOVUP1
2799 MOVE_X      mNEXT
2800
2801
2802 ;-------------------------------------------------------------------------------
2803 ; WORDS SET for VOCABULARY, not ANS compliant
2804 ;-------------------------------------------------------------------------------
2805
2806 ;X VOCABULARY       -- create a vocabulary, up to 7 vocabularies in CONTEXT
2807
2808     .IFDEF VOCABULARY_SET
2809
2810             FORTHWORD "VOCABULARY"
2811 VOCABULARY  mDOCOL
2812             .word   CREATE
2813     .SWITCH THREADS
2814     .CASE   1
2815             .word   lit,0,COMMA             ; will keep the NFA of the last word of the future created vocabularies
2816     .ELSECASE
2817             .word   lit,THREADS,lit,0,xdo
2818 VOCABULOOP  .word   lit,0,COMMA
2819             .word   xloop,VOCABULOOP
2820     .ENDCASE
2821             .word   HERE                    ; link via LASTVOC the future created vocabulary
2822             .word   LIT,LASTVOC,DUP
2823             .word   FETCH,COMMA             ; compile [LASTVOC] to HERE+
2824             .word   STORE                   ; store (HERE - CELL) to LASTVOC
2825             .word   DOES                    ; compile CFA and PFA for the future defined vocabulary
2826
2827     .ENDIF ; VOCABULARY_SET
2828
2829 VOCDOES     .word   LIT,CONTEXT,STORE
2830             .word   EXIT
2831
2832 ;X  FORTH    --                         ; set FORTH the first context vocabulary; FORTH is and must be the first vocabulary
2833     .IFDEF VOCABULARY_SET
2834             FORTHWORD "FORTH"
2835     .ENDIF ; VOCABULARY_SET
2836 FORTH                                   ; leave BODYFORTH on the stack and run VOCDOES
2837             mDODOES                     ; Code Field Address (CFA) of FORTH
2838 PFAFORTH    .word   VOCDOES             ; Parameter Field Address (PFA) of FORTH
2839 BODYFORTH                               ; BODY of FORTH
2840             .word   lastforthword
2841     .SWITCH THREADS
2842     .CASE   2
2843             .word   lastforthword1
2844     .CASE   4
2845             .word   lastforthword1
2846             .word   lastforthword2
2847             .word   lastforthword3
2848     .CASE   8
2849             .word   lastforthword1
2850             .word   lastforthword2
2851             .word   lastforthword3
2852             .word   lastforthword4
2853             .word   lastforthword5
2854             .word   lastforthword6
2855             .word   lastforthword7
2856     .CASE   16
2857             .word   lastforthword1
2858             .word   lastforthword2
2859             .word   lastforthword3
2860             .word   lastforthword4
2861             .word   lastforthword5
2862             .word   lastforthword6
2863             .word   lastforthword7
2864             .word   lastforthword8
2865             .word   lastforthword9
2866             .word   lastforthword10
2867             .word   lastforthword11
2868             .word   lastforthword12
2869             .word   lastforthword13
2870             .word   lastforthword14
2871             .word   lastforthword15
2872     .CASE   32
2873             .word   lastforthword1
2874             .word   lastforthword2
2875             .word   lastforthword3
2876             .word   lastforthword4
2877             .word   lastforthword5
2878             .word   lastforthword6
2879             .word   lastforthword7
2880             .word   lastforthword8
2881             .word   lastforthword9
2882             .word   lastforthword10
2883             .word   lastforthword11
2884             .word   lastforthword12
2885             .word   lastforthword13
2886             .word   lastforthword14
2887             .word   lastforthword15
2888             .word   lastforthword16
2889             .word   lastforthword17
2890             .word   lastforthword18
2891             .word   lastforthword19
2892             .word   lastforthword20
2893             .word   lastforthword21
2894             .word   lastforthword22
2895             .word   lastforthword23
2896             .word   lastforthword24
2897             .word   lastforthword25
2898             .word   lastforthword26
2899             .word   lastforthword27
2900             .word   lastforthword28
2901             .word   lastforthword29
2902             .word   lastforthword30
2903             .word   lastforthword31
2904
2905     .ELSECASE   ; = CASE 1
2906     .ENDCASE
2907             .word   voclink         ; here, voclink = 0
2908 voclink         .set    $-2
2909
2910
2911     .IFDEF MSP430ASSEMBLER
2912 ;X  ASSEMBLER       --              ; set ASSEMBLER the first context vocabulary
2913     .IFDEF VOCABULARY_SET
2914             FORTHWORD "ASSEMBLER"
2915     .ENDIF ; VOCABULARY_SET
2916 ASSEMBLER       mDODOES             ; leave BODYASSEMBLER on the stack and run VOCDOES
2917                 .word   VOCDOES
2918 BODYASSEMBLER   .word   lastasmword ; here is the structure created by VOCABULARY
2919     .SWITCH THREADS
2920     .CASE   2
2921                 .word   lastasmword1
2922     .CASE   4
2923                 .word   lastasmword1
2924                 .word   lastasmword2
2925                 .word   lastasmword3
2926     .CASE   8
2927                 .word   lastasmword1
2928                 .word   lastasmword2
2929                 .word   lastasmword3
2930                 .word   lastasmword4
2931                 .word   lastasmword5
2932                 .word   lastasmword6
2933                 .word   lastasmword7
2934     .CASE   16
2935                 .word   lastasmword1
2936                 .word   lastasmword2
2937                 .word   lastasmword3
2938                 .word   lastasmword4
2939                 .word   lastasmword5
2940                 .word   lastasmword6
2941                 .word   lastasmword7
2942                 .word   lastasmword8
2943                 .word   lastasmword9
2944                 .word   lastasmword10
2945                 .word   lastasmword11
2946                 .word   lastasmword12
2947                 .word   lastasmword13
2948                 .word   lastasmword14
2949                 .word   lastasmword15
2950     .CASE   32
2951                 .word   lastasmword1
2952                 .word   lastasmword2
2953                 .word   lastasmword3
2954                 .word   lastasmword4
2955                 .word   lastasmword5
2956                 .word   lastasmword6
2957                 .word   lastasmword7
2958                 .word   lastasmword8
2959                 .word   lastasmword9
2960                 .word   lastasmword10
2961                 .word   lastasmword11
2962                 .word   lastasmword12
2963                 .word   lastasmword13
2964                 .word   lastasmword14
2965                 .word   lastasmword15
2966                 .word   lastasmword16
2967                 .word   lastasmword17
2968                 .word   lastasmword18
2969                 .word   lastasmword19
2970                 .word   lastasmword20
2971                 .word   lastasmword21
2972                 .word   lastasmword22
2973                 .word   lastasmword23
2974                 .word   lastasmword24
2975                 .word   lastasmword25
2976                 .word   lastasmword26
2977                 .word   lastasmword27
2978                 .word   lastasmword28
2979                 .word   lastasmword29
2980                 .word   lastasmword30
2981                 .word   lastasmword31
2982     .ELSECASE
2983     .ENDCASE
2984                 .word   voclink
2985 voclink         .set    $-2
2986
2987     .ENDIF ; MSP430ASSEMBLER
2988
2989 ;X  ALSO    --                  make room to put a vocabulary as first in context
2990     .IFDEF VOCABULARY_SET
2991             FORTHWORD "ALSO"
2992     .ENDIF ; VOCABULARY_SET
2993 ALSO        MOV #12,W               ; -- move up 6 words, 8th word of CONTEXT area must remain to 0
2994             MOV #CONTEXT,X          ; X=src
2995             MOV #CONTEXT+2,Y        ; Y=dst
2996             JMP MOVEUP              ; src < dst
2997
2998 ;X  PREVIOUS   --               pop last vocabulary out of context
2999     .IFDEF VOCABULARY_SET
3000             FORTHWORD "PREVIOUS"
3001     .ENDIF ; VOCABULARY_SET
3002 PREVIOUS    MOV #14,W               ; move down 7 words, with recopy of the 8th word equal to 0
3003             MOV #CONTEXT+2,X        ; X=src
3004             MOV #CONTEXT,Y          ; Y=dst
3005             JMP MOVEDOWN            ; src > dst
3006
3007 ;X ONLY     --      cut context list to access only first vocabulary, ex.: FORTH ONLY
3008     .IFDEF VOCABULARY_SET
3009             FORTHWORD "ONLY"
3010     .ENDIF ; VOCABULARY_SET
3011 ONLY        MOV #0,&CONTEXT+2
3012             mNEXT
3013
3014 ;X DEFINITIONS  --      set last context vocabulary as entry for further defining words
3015     .IFDEF VOCABULARY_SET
3016             FORTHWORD "DEFINITIONS"
3017     .ENDIF ; VOCABULARY_SET
3018 DEFINITIONS  MOV &CONTEXT,&CURRENT
3019             mNEXT
3020
3021 ; ------------------------------------------------------------------------------
3022 ; forthMSP430FR :  CONDITIONNAL COMPILATION
3023 ; ------------------------------------------------------------------------------
3024     .IFDEF CONDCOMP
3025         .include "forthMSP430FR_CONDCOMP.asm"
3026
3027         ; compile COMPARE [THEN] [ELSE] [IF] [UNDEFINED] [DEFINED] MARKER
3028
3029     .ENDIF
3030 ; ------------------------------------------------------------------------------
3031 ;-------------------------------------------------------------------------------
3032 ; IMPROVED ON/OFF AND RESET
3033 ;-------------------------------------------------------------------------------
3034
3035 STATE_DOES  ; execution part of PWR_STATE ; sorry, doesn't restore search order pointers
3036             .word   FORTH,ONLY,DEFINITIONS
3037             FORTHtoASM              ; -- BODY       IP is free
3038             MOV @TOS+,W             ; -- BODY+2     W = old VOCLINK = VLK
3039             MOV W,&LASTVOC          ;               restore LASTVOC
3040             MOV @TOS,TOS            ; -- OLD_DP
3041             MOV TOS,&DDP            ; -- DP         restore DP
3042                                     ; then restore words link(s) with it value < old DP
3043     .SWITCH THREADS
3044     .CASE   1 ; mono thread vocabularies
3045 MARKALLVOC  MOV W,Y                 ; -- DP         W=VLK   Y=VLK
3046 MRKWORDLOOP MOV -2(Y),Y             ; -- DP         W=VLK   Y=NFA
3047             CMP Y,TOS               ; -- DP         CMP = TOS-Y : OLD_DP-NFA
3048             JNC MRKWORDLOOP         ;                loop back if TOS<Y : OLD_DP<NFA
3049             MOV Y,-2(W)             ;                W=VLK   X=THD   Y=NFA   refresh thread with good NFA
3050             MOV @W,W                ; -- DP         W=[VLK] = next voclink
3051             CMP #0,W                ; -- DP         W=[VLK] = next voclink   end of vocs ?
3052             JNZ MARKALLVOC          ; -- DP         W=VLK                   no : loopback
3053
3054     .ELSECASE ; multi threads vocabularies
3055 MARKALLVOC  MOV #THREADS,IP         ; -- DP         W=VLK
3056             MOV W,X                 ; -- DP         W=VLK   X=VLK
3057 MRKTHRDLOOP MOV X,Y                 ; -- DP         W=VLK   X=VLK   Y=VLK
3058             SUB #2,X                ; -- DP         W=VLK   X=THD (thread ((case-2)to0))
3059 MRKWORDLOOP MOV -2(Y),Y             ; -- DP         W=VLK   Y=NFA
3060             CMP Y,TOS               ; -- DP         CMP = TOS-Y : DP-NFA
3061             JNC MRKWORDLOOP         ;               loop back if TOS<Y : DP<NFA
3062 MARKTHREAD  MOV Y,0(X)              ;               W=VLK   X=THD   Y=NFA   refresh thread with good NFA
3063             SUB #1,IP               ; -- DP         W=VLK   X=THD   Y=NFA   IP=CFT-1
3064             JNZ MRKTHRDLOOP         ;                       loopback to compare NFA in next thread (thread-1)
3065             MOV @W,W                ; -- DP         W=[VLK] = next voclink
3066             CMP #0,W                ; -- DP         W=[VLK] = next voclink   end of vocs ?
3067             JNZ MARKALLVOC          ; -- DP         W=VLK                   no : loopback
3068
3069     .ENDCASE ; of THREADS           ; -- DP
3070             MOV     @PSP+,TOS       ;
3071             MOV     @RSP+,IP        ;
3072             mNEXT                   ;
3073
3074             FORTHWORD "PWR_STATE"   ; executed by power ON, reinitializes dictionary in state defined by PWR_HERE
3075 PWR_STATE   mDODOES                 ; DOES part of MARKER : resets pointers DP, voclink and latest
3076             .word   STATE_DOES      ; execution vector of PWR_STATE
3077 MARKVOC     .word   lastvoclink     ; initialised by forthMSP430FR.asm as voclink value
3078 MARKDP      .word   ROMDICT         ; initialised by forthMSP430FR.asm as DP value
3079
3080             FORTHWORD "RST_STATE"   ; executed by <reset>, reinitializes dictionary in state defined by RST_HERE
3081 RST_STATE   MOV &INIVOC,&MARKVOC    ; INIT value above (FRAM value)
3082             MOV &INIDP,&MARKDP      ; INIT value above (FRAM value)
3083             JMP PWR_STATE
3084
3085             FORTHWORD "PWR_HERE"    ; define dictionnary bound for power ON
3086 PWR_HERE    MOV &LASTVOC,&MARKVOC
3087             MOV &DDP,&MARKDP
3088             mNEXT
3089
3090             FORTHWORD "RST_HERE"    ; define dictionnary bound for <reset>...
3091 RST_HERE    MOV &LASTVOC,&INIVOC
3092             MOV &DDP,&INIDP
3093             JMP PWR_HERE            ; ...and obviously same bound for power ON...
3094
3095         FORTHWORD "WIPE"            ; restore the program as it was in forthMSP430FR.txt file
3096 WIPE                                ; reset JTAG and BSL signatures   ; unlock JTAG, SBW and BSL
3097         MOV #16,X                   ; max known SIGNATURES length = 16
3098 SIGNLOO SUB #2,X
3099         MOV #-1,SIGNATURES(X)       ; reset signature; WARNING ! DON'T CHANGE IMMEDIATE VALUE !
3100         JNZ SIGNLOO
3101         MOV #BODYSLEEP,&PFASLEEP    ;4 MOV #SLEEP,X ADD #4,X MOV X,-2(X), restore default background task
3102         MOV #BODYWARM,&PFAWARM      ;4 ' WARM >BODY IS WARM, restore default WARM
3103     .IFDEF DEFER_QUIT               ;  true if BOOTLOADER
3104         MOV #BODYQUIT,&PFAQUIT      ;4 ' QUIT >BODY IS QUIT
3105     .ENDIF
3106         MOV #lastvoclink,&INIVOC    ; reinit this 2 factory values
3107         MOV #ROMDICT,&INIDP
3108         PUSH #RST_STATE             ; define the next of WIPE
3109 ;-----------------------------------;
3110 ; WIPE, QABORT common subroutine    ; <--- ?ABORT calls here
3111 ;-----------------------------------;
3112 QAB_DEFER
3113         MOV #BODYEMIT,&PFAEMIT      ;4 ' EMIT >BODY IS EMIT   default console output
3114         MOV #BODYCR,&PFACR          ;4 ' CR >BODY IS CR       default CR
3115         MOV #BODYKEY,&PFAKEY        ;4 ' KEY >BODY IS KEY     default KEY
3116     .IFDEF DEFER_ACCEPT             ;  true if SD_LOADER
3117         MOV #BODYACCEPT,&PFAACCEPT  ;4 ' ACCEPT >BODY IS ACCEPT
3118         MOV #TIB_ORG,&PFACIB        ;4 TIB_ORG TO CIB  (Current Input Buffer)
3119     .ENDIF
3120 ;-----------------------------------;
3121 ; WIPE, QABORT, COLD common subrouti; <--- COLD, reset and PUC calls here
3122 ;-----------------------------------;
3123 RST_INIT
3124         MOV #CPUOFF+GIE,&LPM_MODE   ; set LPM0
3125     .SWITCH DTC
3126     .CASE 1
3127         MOV #xdocol,rDOCOL
3128     .CASE 2
3129         MOV #EXIT,rDOCOL
3130     .ENDCASE
3131         MOV #xdovar,rDOVAR
3132         MOV #xdocon,rDOCON
3133         MOV #xdodoes,rDODOES
3134     .IFDEF MSP430ASSEMBLER
3135         MOV #RAM_ASM_LEN,X          ; reset all 6 branch labels + SAVECURRENT + RPT_WORD if any
3136 CLR_RAM_ASM
3137         SUB #2,X
3138         MOV #0,RAM_ASM(X)           ;
3139         JNZ CLR_RAM_ASM             ;
3140     .ENDIF
3141         MOV #10,&BASE               ;4
3142         MOV #32,&CAPS               ; init CAPS ON
3143         RET
3144 ;---------------------------------------;
3145
3146 ; --------------------------------------------------------------------------------
3147 ; forthMSP430FR : WARM
3148 ; --------------------------------------------------------------------------------
3149
3150 ;Z WARM   --    ; deferred word, enabling the initialisation of your application
3151             FORTHWORD "WARM"
3152 WARM        MOV @PC+,PC             ;3  Code Field Address (CFA) of WARM
3153 PFAWARM     .word   BODYWARM        ;   Parameter Field Address of WARM, may be redirected.
3154 BODYWARM    MOV @PC+,IP             ; MOV [BODYWARM+2],IP
3155             .word   WARMTYPE        ; define next step of WARM, examples: WARMTYPE, ABORT, BOOT...
3156                                     ;
3157 ;=================================================================================
3158 ; WARM 1: activates I/O: inputs and outputs are active only here (hiZ before here)
3159 ;=================================================================================
3160     BIC #LOCKLPM5,&PM5CTL0          ; activate all previous I/O settings (before I/O tests below).
3161                                     ; Moved in WARM area to be redirected in your app START routine,
3162                                     ; enabling you full control of the I/O RESET state.
3163 ;=================================================================================
3164     MOV &SAVE_SYSRSTIV,TOS          ;
3165     CMP #0,TOS                      ; WARM event ?
3166     JZ RST_SEL_END                  ; yes
3167 ;---------------------------------------------------------------------------------
3168 ; RESET 7: test DEEP RESET before init TERMINAL I/O
3169 ;---------------------------------------------------------------------------------
3170 RST_EVENT
3171     BIT.B #TXD,&TERM_IN             ; TERM_TXD wired to GND via 4k7 resistor ?
3172     JNZ RST_TERM_IO                 ; no
3173     XOR #-1,TOS                     ; yes : force DEEP_RST (RESET + WIPE)
3174     ADD #1,TOS                      ;       to display SAVE_SYSRSTIV as negative value
3175 ;---------------------------------------------------------------------------------
3176 ; RESET 8: INIT TERMINAL I/O
3177 ;---------------------------------------------------------------------------------
3178 RST_TERM_IO                         ;
3179     BIS.B #TERM_BUS,&TERM_SEL       ; Configure pins TXD & RXD for TERM_UART
3180 ;---------------------------------------------------------------------------------
3181 ; RESET 9: INIT SD_Card
3182 ;---------------------------------------------------------------------------------
3183     .IFDEF SD_CARD_LOADER           ;
3184         BIT.B #SD_CD,&SD_CDIN       ; SD_memory in SD_Card module ?
3185         JNZ RST_SEL                 ; no
3186         .IF RAM_LEN < 2048          ; case of MSP430FR57xx : SD datas are in FRAM
3187             MOV #SD_LEN,X           ;                        not initialised by RESET.
3188 ClearSDdata SUB #2,X                ; 1
3189             MOV #0,SD_ORG(X)        ; 3
3190             JNZ ClearSDdata         ; 2
3191         .ENDIF
3192     .include "forthMSP430FR_SD_INIT.asm"; no use IP,TOS
3193     .ENDIF
3194 ;---------------------------------------------------------------------------------
3195 ; RESET 10, RESET events handler: Select POWER_ON|<reset>|DEEP_RST
3196 ;---------------------------------------------------------------------------------
3197 RST_SEL     CMP #0Ah,TOS            ; SYSRSTIV = security violation: access of protected areas.
3198             JZ WIPE                 ; Add WIPE to this reset to do DEEP_RST
3199             CMP #16h,TOS            ; SYSRSTIV > software POR : failure or DEEP_RST request
3200             JHS WIPE                ; yes, reset event adds WIPE to this reset to do DEEP_RST
3201             CMP #2,TOS              ; SYSRSTIV = BOR ?
3202             JZ  PWR_STATE           ; yes   execute PWR_STATE, return to [BODYWARM+2]
3203             JHS RST_STATE           ; if  SYSRSTIV > BOR  execute RST_STATE, return to [BODYWARM+2]
3204 RST_SEL_END mNEXT                   ; if SYSRSTIV = 1|0 return to [BODYWARM+2]
3205
3206 ;---------------------------------------------------------------------------------
3207 ; WARM 2: type message on console output (if ECHO)
3208 ;---------------------------------------------------------------------------------
3209 WARMTYPE    .word   XSQUOTE         ;
3210             .byte   6,13,1Bh,"[7m#" ; CR + cmd "reverse video" + #
3211             .word   TYPE            ;
3212             .word   DOT             ; display signed SAVE_SYSRSTIV
3213             .word   XSQUOTE
3214             .byte   31,"FastForth ",VER," (C)J.M.Thoorens "
3215             .word   TYPE
3216             .word   LIT,SIGNATURES,HERE,MINUS,UDOT
3217             .word   XSQUOTE         ;
3218             .byte   11,"bytes free ";
3219             .word   BRAN,QABORT_DISPLAY  ;
3220
3221 ;Z COLD     --      performs a software reset (SYSRSTIV = 6)
3222         FORTHWORD "COLD"
3223 COLD    BIT #1,&TERM_STATW              ;
3224         JNZ COLD                        ; loop back while TERM_UART is busy
3225         MOV #0A500h+PMMSWBOR,&PMMCTL0   ; performs reset next address
3226
3227 ;---------------------------------------------------------------------------------
3228 ; RESET 1: Initialisation limited to FastForth usage : I/O, RAM, RTC
3229 ;          all unused I/O are set as input with pullup resistor
3230 ;---------------------------------------------------------------------------------
3231 RESET      .include "TargetInit.asm"    ; include target specific FastForth init code
3232 ;---------------------------------------------------------------------------------
3233 ; RESET 2: init RAM
3234 ;---------------------------------------------------------------------------------
3235             MOV #RAM_LEN,X
3236 INITRAMLOOP SUB #2,X
3237             MOV #0,RAM_ORG(X)
3238             JNZ INITRAMLOOP         ; 6~ loop
3239 ;---------------------------------------------------------------------------------
3240 ; RESET 3: set all interrupt vectors
3241 ;---------------------------------------------------------------------------------
3242             MOV #VECT_LEN,X             ;2 length of vectors area
3243 VECTORLOOP  SUB #2,X                    ;1
3244             MOV #RESET,VECT_ORG(X)      ;4 begin at end of area
3245             JNZ VECTORLOOP              ;2 endloop when VECT_ORG(X) = VECT_ORG
3246             MOV #TERMINAL_INT,&TERM_VEC
3247 ;---------------------------------------------------------------------------------
3248 ; RESET 4: INIT TERM_UART UC
3249 ;---------------------------------------------------------------------------------
3250             MOV #0081h,&TERM_CTLW0          ; UC SWRST + UCLK = SMCLK
3251             MOV &TERMBRW_RST,&TERM_BRW      ; RST value in FRAM
3252             MOV &TERMMCTLW_RST,&TERM_MCTLW  ; RST value in FRAM
3253             BIC #UCSWRST,&TERM_CTLW0        ; release from reset...
3254             BIS #UCRXIE,&TERM_IE            ; ... then enable RX interrupt for wake up on terminal input
3255 ;-------------------------------------------------------------------------------
3256 ; RESET 5: optionnal INIT SD_CARD UC
3257 ;-------------------------------------------------------------------------------
3258     .IFDEF SD_CARD_LOADER               ;
3259             MOV #0A981h,&SD_CTLW0       ; UCxxCTL1  = CKPH, MSB, MST, SPI_3, SMCLK  + UCSWRST
3260             MOV #FREQUENCY*3,&SD_BRW    ; UCxxBRW init SPI CLK = 333 kHz ( < 400 kHz) for SD_Card init
3261             BIS.B #SD_CS,&SD_CSDIR      ; SD_CS as output high
3262             BIS #SD_BUS,&SD_SEL         ; Configure pins as SIMO, SOMI & SCK (PxDIR.y are controlled by eUSCI module)
3263             BIC #1,&SD_CTLW0            ; release eUSCI from reset
3264     .ENDIF
3265 ;---------------------------------------------------------------------------------
3266 ; RESET 6: INIT FORTH machine
3267 ;---------------------------------------------------------------------------------
3268             MOV #PSTACK,PSP             ; init parameter stack
3269             MOV #RSTACK,RSP             ; init return stack
3270             PUSH #WARM                  ; return for RST_INIT
3271             JMP RST_INIT
3272
3273 ;-------------------------------------------------------------------------------
3274 ; ASSEMBLER OPTION
3275 ;-------------------------------------------------------------------------------
3276     .IFDEF MSP430ASSEMBLER
3277         .IFDEF EXTENDED_ASM
3278         .include "forthMSP430FR_EXTD_ASM.asm"
3279         .ELSE
3280         .include "forthMSP430FR_ASM.asm"
3281         .ENDIF
3282     .ENDIF
3283
3284
3285
3286 ;-------------------------------------------------------------------------------
3287 ; FIXED POINT OPERATORS OPTION
3288 ;-------------------------------------------------------------------------------
3289     .IFDEF FIXPOINT
3290     .include "ADDON/FIXPOINT.asm"
3291     .ENDIF
3292
3293 ;-------------------------------------------------------------------------------
3294 ; SD CARD FAT OPTIONS
3295 ;-------------------------------------------------------------------------------
3296     .IFDEF SD_CARD_LOADER
3297     .include "forthMSP430FR_SD_LowLvl.asm"  ; SD primitives
3298     .include "forthMSP430FR_SD_LOAD.asm"    ; SD LOAD driver
3299     ;-----------------------------------------------------------------------
3300     ; SD TOOLS
3301     ;-----------------------------------------------------------------------
3302         .IFDEF SD_TOOLS
3303         .include "ADDON/SD_TOOLS.asm"
3304         .ENDIF
3305     ;---------------------------------------------------------------------------
3306     ; SD CARD READ WRITE
3307     ;---------------------------------------------------------------------------
3308         .IFDEF SD_CARD_READ_WRITE
3309         .include "forthMSP430FR_SD_RW.asm"  ; SD Read/Write driver
3310         .ENDIF
3311     .ENDIF
3312
3313 ;-------------------------------------------------------------------------------
3314 ; UTILITY WORDS OPTION
3315 ;-------------------------------------------------------------------------------
3316     .IFDEF UTILITY
3317     .include "ADDON/UTILITY.asm"
3318     .ENDIF
3319
3320 ;-------------------------------------------------------------------------------
3321 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against WIPE)
3322 ;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
3323
3324
3325
3326 ;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
3327 ; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against WIPE)
3328 ;-------------------------------------------------------------------------------
3329
3330 ;-------------------------------------------------------------------------------
3331 ; RESOLVE ASSEMBLY PTR
3332 ;-------------------------------------------------------------------------------
3333
3334     .include "ThingsInLast.inc"