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