X-Git-Url: http://git.osdn.net/view?a=blobdiff_plain;f=forthMSP430FR.asm;h=0830d891123cda76cc3762d5e762f1bad2d5152e;hb=a204bd28a60ae4fa7b7ee0153a0ed03bd968522a;hp=6b91c88140c0cfdf1b6ad9244ed7647530556669;hpb=71618233dba4578394b66fbbd90591cf5eb7a6a9;p=fast-forth%2Fmaster.git diff --git a/forthMSP430FR.asm b/forthMSP430FR.asm index 6b91c88..0830d89 100644 --- a/forthMSP430FR.asm +++ b/forthMSP430FR.asm @@ -1,457 +1,478 @@ ; -*- coding: utf-8 -*- -; http://patorjk.com/software/taag/#p=display&f=Banner&t=Fast Forth - -; Fast Forth For Texas Instrument MSP430FRxxxx FRAM devices -; Copyright (C) <2017> -; -; This program is free software: you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 3 of the License, or -; (at your option) any later version. ; -; This program is distributed in the hope that it will be useful, -; but WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -; GNU General Public License for more details. -; -; You should have received a copy of the GNU General Public License -; along with this program. If not, see . - -;------------------------------------------------------------------------------- -; assembled with MACROASSEMBLER AS (http://john.ccac.rwth-aachen.de:8000/as/) -;------------------------------------------------------------------------------- - .cpu MSP430 - .include "mspregister.mac" ; -; macexp off ; unrem to hide macro results - ;------------------------------------------------------------------------------- ; Vingt fois sur le métier remettez votre ouvrage, ; Polissez-le sans cesse, et le repolissez, -; Ajoutez quelquefois, et souvent effacez. -; Boileau, L'Art poétique +; Ajoutez quelquefois, et souvent effacez. Boileau, L'Art poétique ;------------------------------------------------------------------------------- -;=============================================================================== -;=============================================================================== -;before assembling or programming you must copy your TARGET in param1 (SHIFT+F8) -;=============================================================================== -;=============================================================================== - ;------------------------------------------------------------------------------- -; TARGET configuration SWITCHES ; bytes values are for DTC=1, 8MHz 2457600 bds XON/XOFF +; SCITE editor: copy https://www.scintilla.org/Sc4xx.exe to \prog\scite.exe +;------------------------------------------------------------------------------- +; MACRO ASSEMBLER AS +; unzip http://john.ccac.rwth-aachen.de:8000/ftp/as/precompiled/i386-unknown-win32/aswcurr.zip +;------------------------------------------------------------------------------- + .listing purecode ; reduce listing to true conditionnal parts + MACEXP_DFT noif ; reduce macros listing to true part ;------------------------------------------------------------------------------- -; TOTAL - SUM of (INFO+RAM +VECTORS) = MAIN PROG -;MSP_EXP430FR5739 ;; MSP-EXP430FR5739 launchpad ; 4154 - 160 ( 24 + 86 + 50 ) = 3994 bytes -;MSP_EXP430FR5969 ; MSP-EXP430FR5969 launchpad ; 4136 - 162 ( 24 + 86 + 52 ) = 3974 bytes -MSP_EXP430FR5994 ; MSP-EXP430FR5994 launchpad ; 4172 - 186 ( 24 + 86 + 76 ) = 3986 bytes -;MSP_EXP430FR6989 ; MSP-EXP430FR6989 launchpad ; 4170 - 168 ( 24 + 86 + 58 ) = 4002 bytes -;MSP_EXP430FR4133 ; MSP-EXP430FR4133 launchpad ; 4180 - 140 ( 24 + 86 + 30 ) = 4040 bytes -;CHIPSTICK_FR2433 ; "CHIPSTICK" of M. Ken BOAK ; 4096 - 148 ( 24 + 86 + 38 ) = 3948 bytes -;MY_MSP430FR5738 ; my MSP430FR5738 miniboards ; 4100 - 160 ( 24 + 86 + 50 ) = 3940 bytes -;MY_MSP430FR5738_1 ; MYMSP430FR5738_1 miniboard ; 4100 - 160 ( 24 + 86 + 50 ) = 3940 bytes -;MY_MSP430FR5948 ; my MSP430FR5948 miniboard ; 4110 - 162 ( 24 + 86 + 52 ) = 3948 bytes -;MY_MSP430FR5948_1 ; my MSP430FR5948_1 miniboard ; 4122 - 162 ( 24 + 86 + 52 ) = 3960 bytes -;JMJ_BOX ; JMJ_BOX MSP430FR5738 ; 4088 - 160 ( 24 + 86 + 50 ) = 3928 bytes -;PA8_PA_MSP430 ; PA8_PA_MSP430 MSP430FR5738 ; 4088 - 160 ( 24 + 86 + 50 ) = 3928 bytes - -; choose DTC (Direct Threaded Code) model, if you don't know, choose 1 -DTC .equ 2 ; DTC model 1 : DOCOL = CALL rDOCOL 14 cycles 1 word shortest DTC model - ; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT 13 cycles 2 words good compromize for mix FORTH/ASM code - ; DTC model 3 : inlined DOCOL 9 cycles 4 words fastest - -FREQUENCY .equ 16 ; fully tested at 0.25,0.5,1,2,4,8,16 (and 24 for MSP430FR57xx) MHz -THREADS .equ 16 ; 1, 4, 8, 16, 32 search entries in dictionnary. 16 is the good compromise between speed and size. - ; +40, +66, +90, +154 bytes -TERMINALBAUDRATE .equ 921600 ; choose value considering the frequency and the UART2USB bridge, see choices below. +VER .equ "V307" ; FORTH version - ; select a minima one item below, input terminal don't work if no flow control. -TERMINALXONXOFF ; set 3 wires (GND,RX,TX) XON/XOFF software flow control; unselect if you plan to use binary flows -TERMINALCTSRTS ; +12 bytes to set 4 wires (GND,RX,TX,RTS) hardware input flow control +;=============================================================================== +; before assembling or programming you must set TARGET in scite param1 (SHIFT+F8) +; according to the selected (uncommented) TARGET below +;=============================================================================== - .include "Target.inc" ; to define target config: I/O, memory, SFR, vectors, TERMINAL eUSCI, SD_Card eUSCI, LF_XTAL, - ; but only for FAST FORTH core use, not for your FAST FORTH application. +;=============================================================================== +; FAST FORTH has a minimalistic footprint to enable its use from 8k FRAM devices +; kernel size below are for 8MHz, DTC=1, THREADS=1, 4WIRES (RTS) options +;=============================================================================== +; TARGET ; ;INFO+VECTORS+ MAIN bytes +;MSP_EXP430FR5739 ; compile for MSP-EXP430FR5739 launchpad ; 64 + 128 + 2778 bytes +;MSP_EXP430FR5969 ; compile for MSP-EXP430FR5969 launchpad ; 64 + 128 + 2768 bytes +MSP_EXP430FR5994 ; compile for MSP-EXP430FR5994 launchpad ; 64 + 128 + 2790 bytes +;MSP_EXP430FR6989 ; compile for MSP-EXP430FR6989 launchpad ; 64 + 128 + 2792 bytes +;MSP_EXP430FR4133 ; compile for MSP-EXP430FR4133 launchpad ; 64 + 128 + 2832 bytes +;MSP_EXP430FR2355 ; compile for MSP-EXP430FR2355 launchpad ; 64 + 128 + 2766 bytes +;MSP_EXP430FR2433 ; compile for MSP-EXP430FR2433 launchpad ; 64 + 128 + 2758 bytes +;LP_MSP430FR2476 ; compile for LP_MSP430FR2476 launchpad ; 64 + 128 + 2770 bytes +;CHIPSTICK_FR2433 ; compile for "CHIPSTICK" of M. Ken BOAK ; 64 + 128 + 2758 bytes +;MSP_EXP430FR5972 ; compile for a virtual launchpad ; 64 + 128 + 2804 bytes + +; choose DTC model (Direct Threaded Code); if you don't know, choose 2, because DOCOL routine without using scratch register +DTC .equ 2 ; DTC model 1 : DOCOL = CALL rDOCOL 14 cycles 1 word shortest DTC model + ; DTC model 2 : DOCOL = PUSH IP, CALL rEXIT 13 cycles 2 words best compromize to mix FORTH/ASM code + ; DTC model 3 : inlined DOCOL 9 cycles 4 words fastest + +THREADS .equ 16 ; 1, 2 , 4 , 8 , 16, 32 search entries in dictionnary. + ; +0, +28, +48, +56, +90, +154 bytes, usefull to speed up compilation; + ; the FORTH interpreter is speed up by about a square root factor of THREADS. + +FREQUENCY .equ 1 ; fully tested at 1,2,4,8,16,24 MHz (24 MHz for MSP430FR57xx,MSP430FR2355) +;=============================================================================== +TERMINAL_I2C ; uncomment to select I2C_Master TERMINAL instead of UART TERMINAL +;=============================================================================== + .IFDEF TERMINAL_I2C +MYSLAVEADR .equ 18 ; +;=============================================================================== + .ELSE ; UART TERMINAL +;=============================================================================== +TERMINALBAUDRATE .equ 115200 ; choose value considering the frequency and the UART2USB bridge, see explanations below. ;------------------------------------------------------------------------------- -; KERNEL ADD-ON SWITCHES +TERMINAL3WIRES ; + 18 bytes enable 3 wires (GND,TX,RX) with XON/XOFF software flow control (PL2303TA/HXD, CP2102) +TERMINAL4WIRES ; + 12 bytes enable 4 wires with hardware flow control on RX with RTS (PL2303TA/HXD, FT232RL) +;TERMINAL5WIRES ; + 10 bytes enable 5 wires with hardware flow control on RX/TX with RTS/CTS (PL2303TA/HXD, FT232RL)... ;------------------------------------------------------------------------------- -CONDCOMP ;; + 354 bytes : add conditionnal compilation : [UNDEFINED] [DEFINED] [IF] [ELSE] [THEN], strongly recommended. -MSP430ASSEMBLER ;; + 1894 bytes : add embedded assembler with TI syntax; without, you can do all but all much more slowly... -SD_CARD_LOADER ;; + 1834 bytes : to LOAD source files from SD_card -SD_CARD_READ_WRITE ;; + 1176 bytes : to read, create, write and del files + source files direct copy from PC to SD_Card -BOOTLOADER ; + 50 bytes : add a bootstrap to SD_CARD\BOOT.4TH. -;VOCABULARY_SET ; + 108 bytes : add VOCABULARY FORTH ASSEMBLER ALSO PREVIOUS ONLY DEFINITIONS (FORTH83, not ANSI) -;LOWERCASE ; + 30 bytes : enable to write strings in lowercase. -;BACKSPACE_ERASE ; + 24 bytes : replace BS by ERASE, for visual comfort +;HALFDUPLEX ; switch to UART half duplex TERMINAL input +;=============================================================================== + .ENDIF +;=============================================================================== +; MINIMAL ADDONS if you want a canonical FORTH: CORE_COMPLEMENT + CONDCOMP + PROMPT +;=============================================================================== +; MINIMAL ADDONS for FAST FORTH: MSP430ASSEMBLER + CONDCOMP +;=============================================================================== ;------------------------------------------------------------------------------- -; OPTIONAL KERNELL ADD-ON SWITCHES (can be downloaded later) >------------------+ -; Tip: when switched ON below, ADD-ONs become protected against WIPE and Deep Reset... | -;------------------------------------------------------------------------------- v -;UTILITY ; + 412/494 bytes : add .S .RS WORDS U.R DUMP ? UTILITY.f -;SD_TOOLS ; + 126 bytes for trivial DIR, FAT, CLUSTER and SECTOR view, adds UTILITY SD_TOOLS.f -;ANS_CORE_COMPLIANT ; + 876 bytes : required to pass coretest.4th ; (includes items below) COMPxMPY.f (x = H or S) -;ARITHMETIC ; + 358 bytes : add S>D M* SM/REM FM/MOD * /MOD / MOD */MOD /MOD */ -;DOUBLE ; + 130 bytes : add 2@ 2! 2DUP 2SWAP 2OVER -;ALIGNMENT ; + 24 bytes : add ALIGN ALIGNED -;PORTABILITY ; + 46 bytes : add CHARS CHAR+ CELLS CELL+ - - +; KERNEL ADDONs that can't be added later +;------------------------------------------------------------------------------- +MSP430ASSEMBLER ; + 1812 bytes : adds embedded assembler with TI syntax; without, you can do all but bigger and slower... +CONDCOMP ; + 306 bytes : adds conditionnal compilation [IF] [ELSE] [THEN] [DEFINED] [UNDEFINED] +DOUBLE_INPUT ; + 56 bytes : adds the interpretation engine for double numbers (numbers with dot) +FIXPOINT_INPUT ; + 74 bytes : adds the interpretation engine for Q15.16 numbers (numbers with comma) +DEFERRED ; + 124 bytes : adds DEFER IS :NONAME CODENNM (CODE_No_NaMe), useful for interrupts start and stop. +VOCABULARY_SET ; + 174 bytes : adds words: VOCABULARY FORTH ASSEMBLER ALSO PREVIOUS ONLY DEFINITIONS (FORTH83) +EXTENDED_MEM ; + 740 bytes : allows assembler to execute code up to 1MB (LARGE_CODE). +EXTENDED_ASM ; + 1260 bytes : extended assembler to 20 bits datas (LARGE_DATA + LARGE_CODE). +SD_CARD_LOADER ; + 1766 bytes : to load source files from SD_card +SD_CARD_READ_WRITE ; + 1148 bytes : to read, create, write and del files + copy text files from PC to target SD_Card +BOOTLOADER ; + 132 bytes : includes in WARM process the bootloader SD_CARD\BOOT.4TH. +;PROMPT ; + 22 bytes : to display prompt "ok " +;------------------------------------------------------------------------------- + +;------------------------------------------------------------------------------- +; OPTIONS that can be added later by downloading their source file >-----------------------+ +; however, added here, they are protected against WIPE and Deep Reset. | +;------------------------------------------------------------------------------- v +;CORE_COMPLEMENT ; + 1974 bytes : MINIMAL OPTIONS if you want a conventional FORTH CORECOMP.f +;FIXPOINT ; + 422/528 bytes add HOLDS F+ F- F/ F* F#S F. S>F FIXPOINT.f +;UTILITY ; + 434/524 bytes (1/16threads) : add .S .RS WORDS U.R DUMP ? UTILITY.f +;SD_TOOLS ; + 142 bytes for trivial DIR, FAT, CLUSTR. and SECTOR. view, (adds UTILITY) SD_TOOLS.f + .save + .listing off ;=============================================================================== -; XON/XOFF control flow configuration ; up to 322kBd/MHz with ECHO +; Software control flow XON/XOFF configuration: ;=============================================================================== +; Launchpad <-> UARTtoUSB device <-> TeraTerm TERMINAL +; RX <-- TX +; TX --> RX +; GND <-> GND +; +; TERATERM config terminal: NewLine receive : LF, +; NewLine transmit : CR+LF +; Size : 96 chars x 49 lines (adjust lines according to your display) +; +; TERATERM config serial port: TERMINALBAUDRATE value, +; 8 bits, no parity, 1 Stop bit, +; XON/XOFF flow control, +; delay = 0ms/line, 0ms/char +; +; don't forget to save always new TERATERM configuration ! -; Only two usb2uart bridges correctly handle XON/XOFF: cp2102 and pl2303. - -; the best and cheapest: UARTtoUSB cable with Prolific PL2303TA (supply current = 8 mA) or PL2303HXD -; ...but pl2303HXD cable have not the 3.3V pin... -; I bought a cable pl2303TA plus a cable pl2303HXD, and I recovered the 6-wire cable of the HXD to weld it on -; the TA. I obtain a PL2303TA cable with GND, 3.3V, RX TX, CTS and RTS. -;============================================================================================================== -;============================================================================================================== -; About pl2303 USB2UART bridge: XON/XOFF no longer works with new driver v3.8.12.0 (03/03/2017)... -; So, get on web the previous PL2303_Prolific_DriverInstaller_v1160.exe (or .zip) and save it before install. -;============================================================================================================== -;============================================================================================================== -; -------------------------------------------------------------------------------------------- -; WARNING ! if you use PL2303TA cable as supply, open box before to weld red wire on 3v3 pad ! -; -------------------------------------------------------------------------------------------- -; 9600,19200,38400,57600 (250kHz) -; + 115200,134400 (500kHz) -; + 201600,230400,268800 (1MHz) -; + 403200,460800,614400 (2MHz) -; + 806400,921600,1228800 (4MHz) -; + 2457600 (8MHz) -; + 3000000 (16MHz) -; + 6000000 (24MHz, MSP430FR57xx) - +; ------------------------------------------------------------------------------ +; Only two usb2uart bridges correctly handle XON / XOFF: cp2102 and pl2303. +; ------------------------------------------------------------------------------ +; the best and cheapest: UARTtoUSB cable with Prolific PL2303HXD (or PL2303TA) +; works well in 3 WIRES (XON/XOFF) and 4WIRES (GND,RX,TX,RTS) config +; ------------------------------------------------------------------------------ +; PL2303TA 4 wires CABLE PL2303HXD 6 wires CABLE +; pads upside: 3V3,txd,rxd,gnd,5V pads upside: gnd, 3V3,txd,rxd,5V +; downside: cts,dcd,dsr,rts,dtr downside: rts,cts +; ------------------------------------------------------------------------------ +; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad ! +; ------------------------------------------------------------------------------ +; up to 115200 Bds (500kHz) +; up to 230400 Bds (1MHz) +; up to 460800 Bds (2MHz) +; up to 921600 Bds (4MHz) +; up to 1843200 Bds (8MHz) +; up to 3 MBds (12MHz,PL2303HXD with shortened cable < 20cm) +; up to 4 MBds (16MHz,PL2303HXD with shortened cable < 20cm) +; up to 5 MBds (20MHz,PL2303HXD with shortened cable < 20cm) +; up to 6 MBds (24MHz,PL2303HXD with shortened cable < 20cm) ; UARTtoUSB module with Silabs CP2102 (supply current = 20 mA) -; --------------------------------------------------------------------------------------------------- +; ------------------------------------------------------------------------------ ; WARNING ! if you use it as supply, buy a CP2102 module with a VCC switch 5V/3V3 and swith on 3V3 ! -; --------------------------------------------------------------------------------------------------- +; ------------------------------------------------------------------------------ ; 9600,19200,38400 (250kHz) -; + 57600 (500kHz) -; + 115200,134400,230400 (1MHz) +; + 57600, 115200 (500kHz) +; + 134400,230400 (1MHz) ; + 460800 (2MHz) -; + 921600 (4MHz) -; + 1382400,1843200 (8MHz) (must be reprogrammed) -; + 4000000 (16MHz,24MHz) (must be reprogrammed) -; ...But beyond 921600 bds, while the download is done without errors, some chars issued by FAST FORTH are lost ... +; + 921600 (4MHz,8MHz,16MHz,24MHz) + +;=============================================================================== +; Hardware control flow configuration: RTS is wired on UART2USB CTS pin +;=============================================================================== -; Launchpad --- UARTtoUSB device +; Launchpad <-> UARTtoUSB ; RX <-- TX ; TX --> RX +; RTS --> CTS (see launchpad.asm for RTS selected pin) ; GND <-> GND -; TERATERM config terminal : NewLine receive : AUTO, +; RTS pin may be permanently wired on SBWTCK/TEST pin without disturbing SBW 2 wires programming + +; TERATERM config terminal : NewLine receive : LF, ; NewLine transmit : CR+LF -; Size : 128 chars x 49 lines (adjust lines to your display) +; Size : 96 chars x 49 lines (adjust lines to your display) ; TERATERM config serial port : TERMINALBAUDRATE value, ; 8bits, no parity, 1Stopbit, -; XON/XOFF flow control, +; Hardware flow control, ; delay = 0ms/line, 0ms/char ; don't forget : save new TERATERM configuration ! - -;=============================================================================== -; Hardware control flow configuration: RTS is wired on UART2USB CTS pin -;=============================================================================== - -; Launchpad <-> UARTtoUSB -; RX <-- TX -; TX --> RX -; RTS --> CTS -; GND <-> GND - -; notice that the control flow seems not necessary for TX +; notice that the control flow seems not necessary for TX (CTS <-- RTS) ; UARTtoUSB module with PL2303TA/HXD -; -------------------------------------------------------------------------------------------- -; WARNING ! if you use PL2303TA cable as supply, open box before to weld red wire on 3v3 pad ! -; -------------------------------------------------------------------------------------------- -; 9600,19200,38400,57600,115200,134400 (500kHz) -; + 201600,230400,268800 (1MHz) -; + 403200,460800,614400 (2MHz) -; + 806400,921600,1228800 (4MHz) -; + 2457600 (8MHz) -; + 3000000 (16MHz, 24MHz with MSP430FR57xx)) - +; ------------------------------------------------------------------------------ +; WARNING ! if you use PL2303TA/HXD cable as supply, open the box before to weld red wire on 3v3 pad ! +; ------------------------------------------------------------------------------ +; up to 250 kbds / MHz +; ---------------------------------- +; 9600,19200,38400,57600 (250kHz) +; + 115200 (500kHz) +; + 201600,230400,250000 (1MHz) +; + 403200,460800 (2MHz) +; + 806400,921600 (4MHz) +; + 1843200 (8MHz) +; + 2764800 (12MHz) +; + 4000000 (16MHz) +; + 5000000 (20MHz) +; + 6000000 (24MHz) ; UARTtoUSB module with FTDI FT232RL (FT230X don't work correctly) -;------------------------------------------------------------------------------- +; ------------------------------------------------------------------------------ ; WARNING ! buy a FT232RL module with a switch 5V/3V3 and select 3V3 ! -;------------------------------------------------------------------------------- +; ------------------------------------------------------------------------------ +; 9600,19200,38400,57600,115200 (500kHz) +; + 230400 (1MHz) +; + 460800 (2MHz) +; + 921600 (4,8,16 MHz) + +; ------------------------------------------------------------------------------ +; UARTtoBluetooth 2.0 module (RN42 sparkfun bluesmirf) at 921600bds +; ------------------------------------------------------------------------------ ; 9600,19200,38400,57600,115200 (500kHz) ; + 230400 (1MHz) ; + 460800 (2MHz) ; + 921600 (4,8,16 MHz) -; TERATERM config terminal : NewLine receive : AUTO, +; RN42 config : connect RN41/RN42 module on teraterm, via USBtoUART bridge, +; ----------- 8n1, 115200 bds, no flow control, echo on +; $$$ // enter control mode, response: AOK +; SU,92 // set 921600 bds, response: AOK +; R,1 // reset module to take effect +; +; connect RN42 module on FastForth target +; add new bluetooth device on windows, password=1234 +; open the created output COMx port with TERATERM at 921600bds + + +; TERATERM config terminal : NewLine receive : LF, ; NewLine transmit : CR+LF ; Size : 128 chars x 49 lines (adjust lines to your display) ; TERATERM config serial port : TERMINALBAUDRATE value, ; 8bits, no parity, 1Stopbit, -; Hardware flow control, +; Hardware flow control or software flow control or ...no flow control! ; delay = 0ms/line, 0ms/char ; don't forget : save new TERATERM configuration ! - -;------------------------------------------------------------------------------- -; DTCforthMSP430FR5xxx Init vocabulary pointers: -;------------------------------------------------------------------------------- - - .IF THREADS = 1 - -voclink .set 0 ; init vocabulary links -forthlink .set 0 -asmlink .set 0 - -FORTHWORD .MACRO name - .word forthlink -forthlink .set $ - .byte STRLEN(name),name -; .align 2 - .ENDM - -FORTHWORDIMM .MACRO name - .word forthlink -forthlink .set $ - .byte STRLEN(name)+128,name -; .align 2 - .ENDM - -asmword .MACRO name - .word asmlink -asmlink .set $ - .byte STRLEN(name),name -; .align 2 - .ENDM - - .ELSE - .include "ForthThreads.mac" - .ENDIF - +; in fact, compared to using a UART USB bridge, only the COMx port is to be updated. +; ------------------------------------------------------------------------------ + .restore + .include "ThingsInFirst.inc" ; macros, target definitions, init FORTH variables... ;------------------------------------------------------------------------------- ; DTCforthMSP430FR5xxx RAM memory map: ;------------------------------------------------------------------------------- -; name words ; comment - -;LSTACK = L0 = LEAVEPTR ; ----- RAMSTART - ; | -LSTACK_SIZE .equ 16 ; | grows up +;---------------------------;--------- +; name words ; comment +;---------------------------;--------- +;LSTACK = L0 = LEAVEPTR ; ----- RAM_ORG ; | +LSTACK_LEN .equ 16 ; | grows up ; V - ; ; ^ +PSTACK_LEN .equ 48 ; | grows down ; | -PSTACK_SIZE .equ 48 ; | grows down - ; | -;PSTACK=S0 ; ----- RAMSTART + $80 - ; +;PSTACK=S0 ; ----- RAM_ORG + $80 ; ^ +RSTACK_LEN .equ 48 ; | grows down ; | -RSTACK_SIZE .equ 48 ; | grows down - ; | -;RSTACK=R0 ; ----- RAMSTART + $E0 - - ; aligned buffers only required for terminal tasks. - -; names bytes ; comments - -;PAD ; ----- RAMSTART + $E2 +;RSTACK=R0 ; ----- RAM_ORG + $E0 + +;---------------------------;--------- +; names bytes ; comments +;---------------------------;--------- +; PAD_I2CADR ; ----- RAM_ORG + $E0 +; PAD_I2CCNT ; +; PAD < ----- RAM_ORG + $E4 ; | PAD_LEN .equ 84 ; | grows up (ans spec. : PAD >= 84 chars) - ; | ; v - ; ----- RAMSTART + $136 -;TIB ; ----- RAMSTART + $138 - ; | -TIB_LEN .equ 80 ; | grows up (ans spec. : TIB >= 80 chars) +; TIB_I2CADR ; ----- RAM_ORG + $138 +; TIB_I2CCNT ; +; TIB < ----- RAM_ORG + $13C ; | +TIB_LEN .equ 84 ; | grows up (ans spec. : TIB >= 80 chars) ; v +; HOLDS_ORG < ------RAM_ORG + $190 ; ^ +HOLD_LEN .equ 34 ; | grows down (ans spec. : HOLD_LEN >= (2*n) + 2 char, with n = 16 bits/cell ; | -HOLD_SIZE .equ 34 ; | grows down (ans spec. : HOLD_SIZE >= (2*n) + 2 char, with n = 16 bits/cell - ; | -;BASE_HOLD ; ----- RAMSTART + $1AA +; HOLD_BASE < ----- RAM_ORG + $1B2 ; -; variables system ; + ; system variables ; - ; ----- RAMSTART + $1DC + ; ----- RAM_ORG + $1E0 ; - ; 32 bytes free + ; 28 bytes free ; -;BUFFER-2 ; ----- RAMSTART + $1FD -;BUFFER ; ----- RAMSTART + $200 +; SD_BUF_I2CADR < ----- RAM_ORG + $1FC +; SD_BUF_I2CCNT ; +; SD_BUF < ----- RAM_ORG + $200 ; - ; 512 bytes buffer +SD_BUF_LEN .equ 200h ; 512 bytes buffer ; - ; ----- RAMSTART + $2FF - -LSTACK .equ RAMSTART -LEAVEPTR .equ LSTACK ; Leave-stack pointer -PSTACK .equ LSTACK+(LSTACK_SIZE*2)+(PSTACK_SIZE*2) -RSTACK .equ PSTACK+(RSTACK_SIZE*2) -PAD_ORG .equ RSTACK+2 -TIB_ORG .equ PAD_ORG+PAD_LEN+2 -BASE_HOLD .equ TIB_ORG+TIB_LEN+HOLD_SIZE - - -; ---------------------------------- -; RAM VARIABLES initialised by RESET -; ---------------------------------- - - .org BASE_HOLD - -HP .word 0 ; HOLD ptr -CAPS .word 0 -LAST_NFA .word 0 ; NFA, VOC_PFA, LFA, CFA, PSP of last created word -LAST_THREAD .word 0 ; used by QREVEAL -LAST_CFA .word 0 -LAST_PSP .word 0 -STATE .word 0 ; Interpreter state -ASM_CURRENT .word 0 ; preserve CURRENT during create assembler words -OPCODE .word 0 ; OPCODE adr -ASMTYPE .word 0 ; keep the opcode complement -SOURCE_LEN .word 0 -SOURCE_ADR .word 0 ; len, addr of input stream -TOIN .word 0 -DDP .word 0 -LASTVOC .word 0 ; keep VOC-LINK -CURRENT .word 0 ; CURRENT dictionnary ptr -CONTEXT .word 0,0,0,0,0,0,0,0 ; CONTEXT dictionnary space (8 CELLS) -BASE .word 0 - - .word 0 ; user free use - .word 0,0,0,0,0,0,0,0 ; user free use - .word 0,0,0,0,0,0,0,0 ; user free use - -; ------------------------------ -; RAM SD_CARD BUFFER 2+512 bytes -; ------------------------------ - - .word 0 ; to able init BufferPtr down to -2 (to skip a CR, for example) -BUFFER -BUFEND .equ BUFFER + 200h ; 512bytes - - -;------------------------------------------------------------------------------- -; INFO(DCBA) >= 256 bytes memory map: -;------------------------------------------------------------------------------- - - .org INFOSTART - -; -------------------------- -; FRAM INFO KERNEL CONSTANTS -; -------------------------- +; SD_BUF_END < ----- RAM_ORG + $400 + +LSTACK .equ RAM_ORG +LEAVEPTR .equ LSTACK ; Leave-stack pointer +PSTACK .equ LSTACK+(LSTACK_LEN*2)+(PSTACK_LEN*2) +RSTACK .equ PSTACK+(RSTACK_LEN*2) +PAD_I2CADR .equ PAD_ORG-4 +PAD_I2CCNT .equ PAD_ORG-2 +PAD_ORG .equ RSTACK+4 +TIB_I2CADR .equ TIB_ORG-4 +TIB_I2CCNT .equ TIB_ORG-2 +TIB_ORG .equ PAD_ORG+PAD_LEN+4 +HOLDS_ORG .equ TIB_ORG+TIB_LEN + +HOLD_BASE .equ HOLDS_ORG+HOLD_LEN + +; ---------------------------------------------------- +; RAM_ORG + $1B2 : RAM VARIABLES +; ---------------------------------------------------- +HP .equ HOLD_BASE ; HOLD ptr +CAPS .equ HOLD_BASE+2 ; CAPS ON = 32, CAPS OFF = 0 +LAST_NFA .equ HOLD_BASE+4 ; NFA, VOC_PFA, CFA, PSP of last created word +LAST_THREAD .equ HOLD_BASE+6 ; used by QREVEAL +LAST_CFA .equ HOLD_BASE+8 +LAST_PSP .equ HOLD_BASE+10 +STATE .equ HOLD_BASE+12 ; Interpreter state +SOURCE .equ HOLD_BASE+14 ; len, org of input stream +SOURCE_LEN .equ HOLD_BASE+14 +SOURCE_ORG .equ HOLD_BASE+16 +TOIN .equ HOLD_BASE+18 ; CurrentInputBuffer pointer +DDP .equ HOLD_BASE+20 ; dictionnary pointer +LASTVOC .equ HOLD_BASE+22 ; keep VOC-LINK +CONTEXT .equ HOLD_BASE+24 ; CONTEXT dictionnary space (8 CELLS) +CURRENT .equ HOLD_BASE+40 ; CURRENT dictionnary ptr +BASE .equ HOLD_BASE+42 +LINE .equ HOLD_BASE+44 ; line in interpretation (see NOECHO, ECHO) + +; --------------------------; +; RAM_ORG + $1E0 : free use ; +; --------------------------; + .IFDEF SD_CARD_LOADER +; -------------------------------------------------- +; RAM_ORG + $1FC : RAM SD_CARD SD_BUF 4 + 512 bytes +; -------------------------------------------------- +SD_BUF_I2CADR .equ SD_BUF-4 +SD_BUF_I2CCNT .equ SD_BUF-2 +SD_BUF .equ HOLD_BASE+78 +SD_BUF_END .equ SD_BUF + 200h ; 512bytes + .ENDIF -INI_THREAD .word THREADS ; used by ADDON_UTILITY.f -INI_TERM .word TERMINAL_INT ; used by RESET - .IF FREQUENCY = 0.25 -FREQ_KHZ .word 250 ; user use - .ELSEIF FREQUENCY = 0.5 -FREQ_KHZ .word 500 ; user use + .org INFO_ORG +;------------------------------------------------------------------------------- +; INFO(DCBA) >= 256 bytes memory map (FRAM) : +;------------------------------------------------------------------------------- +; FRAM INFO: KERNEL INIT CONSTANTS and VARIABLES +; ---------------------------------------------- +FREQ_KHZ .word FREQUENCY*1000 ; used to stabilize MCLK before start, see MSP430FRxxxx.asm + .IFDEF TERMINAL_I2C +I2CSLAVEADR .word MYSLAVEADR ; on MSP430FR2xxx devices with BSL I2C, Slave address is FFA0h +I2CSLAVEADR1 .word 0 +LPM_MODE .word GIE+LPM4 ; LPM4 is the default mode for I2C TERMINAL + .ELSE ; TERMINAL_UART +TERMBRW_RST .word TERMBRW_INI ; set by TERMINALBAUDRATE.inc +TERMMCTLW_RST .word TERMMCTLW_INI ; set by TERMINALBAUDRATE.inc +LPM_MODE .word GIE+LPM0 ; LPM0 is the default mode for UART TERMINAL + .ENDIF +RSTIV_MEM .word -7 ; to do RESET = -3 when compiling new kernel +RST_DP .word ROMDICT ; define RST_STATE +RST_VOC .word lastvoclink ; define RST_STATE +FORTHVERSION .word VAL(SUBSTR(VER,1,0)); used by WARM +INI_THREAD .word THREADS ; used by FF_SPECS.f, UTILITY.f +FORTHADDON .word FADDON ; used by FF_SPECS.f and to secure donwloading of any application.f files. +; --------------------------------------; +WIPE_INI ; MOV #WIPE_INI,X ; WIPE_INI constants are in FRAM INFO= DEEP_RESET init +; --------------------------------------; + .IFNDEF SD_CARD_LOADER +WIPE_COLD .word COLD_TERM ; MOV @X+,&PFACOLD ; COLD_TERM --> PFACOLD +WIPE_INI_FORTH .word RET_ADR ; MOV @X+,&PFA_INI_FORTH; RET_ADR --> PFA_INI_FORTH +WIPE_SLEEP .word RXON ; MOV @X+,&PFASLEEP ; RXON --> PFASLEEP +WIPE_WARM .word INIT_TERM ; MOV @X+,&PFAWARM ; INIT_TERM --> PFAWARM .ELSE -FREQ_KHZ .word FREQUENCY*1000 ; user use +WIPE_COLD .word COLD_TERM ; MOV @X+,&PFACOLD ; COLD_TERM --> PFACOLD +WIPE_INI_FORTH .word INI_FORTH_SD ; MOV @X+,&PFA_INI_FORTH; INI_FORTH_SD --> PFA_INI_FORTH +WIPE_SLEEP .word RXON ; MOV @X+,&PFASLEEP ; RXON --> PFASLEEP +WIPE_WARM .word INIT_SD ; MOV @X+,&PFAWARM ; INIT_SD --> PFAWARM .ENDIF -HECTOBAUDS .word TERMINALBAUDRATE/100 ; user use - -SAVE_SYSRSTIV .word 05 ; value to identify FAST FORTH first start after core recompiling -LPM_MODE .word CPUOFF+GIE ; LPM0 is the default mode -INIDP .word ROMDICT ; define RST_STATE -INIVOC .word lastvoclink ; define RST_STATE - - .word RXON ; user use - .word RXOFF ; user use - - .IFDEF SD_CARD_LOADER - .word ReadSectorWX ; used by ADDON_SD_TOOLS.f - .IFDEF SD_CARD_READ_WRITE - .word WriteSectorWX ; used by ADDON_SD_TOOLS.f - .ELSEIF - .word 0 - .ENDIF ; SD_CARD_READ_WRITE - .ELSEIF - .word 0,0 - .ENDIF ; SD_CARD_LOADER +WIPE_TERM_INT .word TERMINAL_INT ; MOV @X+,&TERM_VEC ; TERMINAL_INT --> TERM_VEC +WIPE_DP .word ROMDICT ; MOV @X+,&RST_DP ; ROMDICT --> RST_DP +WIPE_VOC .word lastvoclink ; MOV @X+,&RST_VOC ; lastvoclink --> RST_VOC +; --------------------------------------; +INI_FORTH_INI ; MOV #INI_FORTH_INI,X, to reset all kernel variables +; --------------------------------------; +WIPE_ACCEPT .word BODYACCEPT ; MOV @X+,&PFAACCEPT ; BODYACCEPT --> PFAACCEPT +WIPE_CR .word BODYCR ; MOV @X+,&PFACR ; BODYCR --> PFACR +INI_FORTH_EMIT .word BODYEMIT ; MOV @X+,&PFAEMIT ; BODYEMIT --> PFAEMIT +WIPE_KEY .word BODYKEY ; MOV @X+,&PFAKEY ; BODYKEY --> PFAKEY +WIPE_CIB .word TIB_ORG ; MOV @X+,&CIB_ADR ; TIB_ORG --> CIB_ADR +; --------------------------------------; +HALF_FORTH_INI ; MOV #HALF_FORTH_INI,X to preserve defered words +; --------------------------------------; + .SWITCH DTC + .CASE 1 +INI_FORTH_COL .word xDOCOL ; MOV @X+,rDOCOL ; init rDOCOL (R4) + .CASE 2 +INI_FORTH_COL .word EXIT ; MOV @X+,rDOCOL ; init rDOCOL (R4) + .CASE 3 + .word 0 ; MOV @X+,R4 ; rDOCOL doesn't exist + .ENDCASE +INI_FORTH_DOES .word xDODOES ; MOV @X+,rDODOES ; init rDODOES (R5) +INI_FORTH_CON .word xDOCON ; MOV @X+,rDOCON ; init rDOCON (R6) +INI_FORTH_VAR .word RFROM ; MOV @X+,rDOVAR ; init rDOVAR (R7) +INI_FORTH_CAPS .word 32 ; MOV @X+,&CAPS ; 32 --> CAPS +INI_FORTH_BASE .word 10 ; MOV @X+,&BASE ; 10 --> BASE +; --------------------------------------; +ABORT_ADR .word ABORT ; user use, QUIT_ADR = ABORT_ADR + 6 +QUIT4_ADR .word QUIT4 ; used by BOOTLOADER + .word 0 ; use free + .word 0 ; use free -; ------------------------------ -; VARIABLES that could be in RAM -; ------------------------------ - .IFNDEF RAM_1K ; if RAM = 1K (FR57xx) the variables below stay in FRAM - .org BUFEND ; else in RAM beyond BUFFER - .ENDIF .IFDEF SD_CARD_LOADER +; --------------------------------------- +; VARIABLES that should be in RAM +; --------------------------------------- + .IF RAM_LEN < 2048 ; if RAM < 2K (FR57xx) the variables below are in INFO space (FRAM) +SD_ORG .equ INFO_ORG+5Ah ; + .ELSE ; if RAM >= 2k the variables below are in RAM +SD_ORG .equ SD_BUF_END+2 ; 1 word guard + .ENDIF -SD_ORG_DATA - .word 0 ; guard word + .org SD_ORG ; --------------------------------------- -; FAT16 FileSystemInfos +; FAT FileSystemInfos ; --------------------------------------- -FATtype .word 0 -BS_FirstSectorL .word 0 ; init by SD_Init, used by RW_Sector_CMD -BS_FirstSectorH .word 0 ; init by SD_Init, used by RW_Sector_CMD -OrgFAT1 .word 0 ; init by SD_Init, -FATSize .word 0 ; init by SD_Init, -OrgFAT2 .word 0 ; init by SD_Init, -OrgRootDIR .word 0 ; init by SD_Init, (FAT16 specific) -OrgClusters .word 0 ; init by SD_Init, Sector of Cluster 0 -SecPerClus .word 0 ; init by SD_Init, byte size +FATtype .equ SD_ORG+0 +BS_FirstSectorL .equ SD_ORG+2 ; init by SD_Init, used by RW_Sector_CMD +BS_FirstSectorH .equ SD_ORG+4 ; init by SD_Init, used by RW_Sector_CMD +OrgFAT1 .equ SD_ORG+6 ; init by SD_Init, +FATSize .equ SD_ORG+8 ; init by SD_Init, +OrgFAT2 .equ SD_ORG+10 ; init by SD_Init, +OrgRootDIR .equ SD_ORG+12 ; init by SD_Init, (FAT16 specific) +OrgClusters .equ SD_ORG+14 ; init by SD_Init, Sector of Cluster 0 +SecPerClus .equ SD_ORG+16 ; init by SD_Init, byte size ; --------------------------------------- ; SD command ; --------------------------------------- -SD_CMD_FRM .byte 0,0,0,0,0,0 ; SD_CMDx inverted frame ${CRC7,ll,LL,hh,HH,CMD} -SectorL .word 0 -SectorH .word 0 - +SD_LOW_LEVEL .equ SD_ORG+18 +SD_CMD_FRM .equ SD_LOW_LEVEL ; SD_CMDx inverted frame ${CRC7,ll,LL,hh,HH,CMD} +SectorL .equ SD_LOW_LEVEL+6 +SectorH .equ SD_LOW_LEVEL+8 ; --------------------------------------- -; BUFFER management +; SD_BUF management ; --------------------------------------- -BufferPtr .word 0 -BufferLen .word 0 - +BufferPtr .equ SD_LOW_LEVEL+10 +BufferLen .equ SD_LOW_LEVEL+12 ; --------------------------------------- ; FAT entry ; --------------------------------------- -ClusterL .word 0 ; -ClusterH .word 0 ; -NewClusterL .word 0 ; -NewClusterH .word 0 ; -CurFATsector .word 0 ; current FATSector of last free cluster - +SD_FAT_LEVEL .equ SD_LOW_LEVEL+14 +ClusterL .equ SD_FAT_LEVEL ; +ClusterH .equ SD_FAT_LEVEL+2 ; +NewClusterL .equ SD_FAT_LEVEL+4 ; +NewClusterH .equ SD_FAT_LEVEL+6 ; +CurFATsector .equ SD_FAT_LEVEL+8 ; current FATSector of last free cluster ; --------------------------------------- ; DIR entry ; --------------------------------------- -DIRClusterL .word 0 ; contains the Cluster of current directory ; = 1 as FAT16 root directory -DIRClusterH .word 0 ; contains the Cluster of current directory ; = 1 as FAT16 root directory -EntryOfst .word 0 -pathname .word 0 ; address of pathname string - +DIRClusterL .equ SD_FAT_LEVEL+10 ; contains the Cluster of current directory ; = 1 as FAT16 root directory +DIRClusterH .equ SD_FAT_LEVEL+12 ; contains the Cluster of current directory ; = 1 as FAT16 root directory +EntryOfst .equ SD_FAT_LEVEL+14 ; --------------------------------------- ; Handle Pointer ; --------------------------------------- -CurrentHdl .word 0 ; contains the address of the last opened file structure, or 0 - +CurrentHdl .equ SD_FAT_LEVEL+16 ; contains the address of the last opened file structure, or 0 ; --------------------------------------- ; Load file operation ; --------------------------------------- -SAVEtsLEN .word 0 ; of previous ACCEPT -SAVEtsPTR .word 0 ; of previous ACCEPT - .word 0 ; - .word 0 ; - .word 0 - +pathname .equ SD_FAT_LEVEL+18 ; start address +EndOfPath .equ SD_FAT_LEVEL+20 ; end address ; --------------------------------------- ; Handle structure ; --------------------------------------- +FirstHandle .equ SD_FAT_LEVEL+22 ; three handle tokens : ; HDLB_Token= 0 : free handle ; = 1 : file to read @@ -459,2266 +480,1815 @@ SAVEtsPTR .word 0 ; of previous ACCEPT ; =-1 : LOAD"ed file (source file) ; offset values -HDLW_PrevHDL .equ 0 ; previous handle ; used by LOAD" +HDLW_PrevHDL .equ 0 ; previous handle HDLB_Token .equ 2 ; token HDLB_ClustOfst .equ 3 ; Current sector offset in current cluster (Byte) HDLL_DIRsect .equ 4 ; Dir SectorL HDLH_DIRsect .equ 6 ; Dir SectorH -HDLW_DIRofst .equ 8 ; BUFFER offset of Dir entry +HDLW_DIRofst .equ 8 ; SD_BUF offset of Dir entry HDLL_FirstClus .equ 10 ; File First ClusterLo (identify the file) -HDLH_FirstClus .equ 12 ; File First ClusterHi (byte) +HDLH_FirstClus .equ 12 ; File First ClusterHi (identify the file) HDLL_CurClust .equ 14 ; Current ClusterLo HDLH_CurClust .equ 16 ; Current ClusterHi HDLL_CurSize .equ 18 ; written size / not yet read size (Long) HDLH_CurSize .equ 20 ; written size / not yet read size (Long) -HDLW_BUFofst .equ 22 ; BUFFER offset ; used by LOAD" - - - .IFDEF RAM_1K ; RAM_Size = 1k, no SDIB due to the lack of RAM -FirstHandle -HandleMax .equ 7 -HandleLenght .equ 24 +HDLW_BUFofst .equ 22 ; SD_BUF offset ; used by LOAD" +HDLW_PrevLEN .equ 24 ; previous LEN +HDLW_PrevORG .equ 26 ; previous ORG + + .IF RAM_LEN < 2048 ; due to the lack of RAM, only 4 handles and PAD replaces SDIB +HandleMax .equ 4 ; and not 8 to respect INFO size (FRAM) +HandleLenght .equ 28 +HandlesLen .equ handleMax*HandleLenght HandleEnd .equ FirstHandle+handleMax*HandleLenght - - .org HandleEnd - - .ELSEIF ; RAM_Size >= 2k -FirstHandle +SD_END .equ HandleEnd +SDIB_I2CADR .equ PAD_ORG-4 +SDIB_I2CCNT .equ PAD_ORG-2 +SDIB_ORG .equ PAD_ORG + .ELSE ; RAM_Size >= 2k all is in RAM HandleMax .equ 8 -HandleLenght .equ 24 +HandleLenght .equ 28 +HandlesLen .equ handleMax*HandleLenght HandleEnd .equ FirstHandle+handleMax*HandleLenght - - .org HandleEnd -SDIB -SDIB_LEN .equ 84 - - .org SDIB+SDIB_LEN - +SDIB_I2CADR .equ SDIB_ORG-4 +SDIB_I2CCNT .equ SDIB_ORG-2 +SDIB_ORG .equ HandleEnd+4 +SDIB_LEN .equ 84 ; = TIB_LEN = PAD_LEN +SD_END .equ SDIB_ORG+SDIB_LEN .ENDIF ; RAM_Size - +SD_LEN .equ SD_END-SD_ORG .ENDIF ; SD_CARD_LOADER +; --------------------------; +; INFO_ORG + $40 : free use ; +; --------------------------; -SD_END_DATA ; used by SD_INIT to init SD_ram area - + .org MAIN_ORG ;------------------------------------------------------------------------------- ; DTCforthMSP430FR5xxx program (FRAM) memory ;------------------------------------------------------------------------------- +; here we place the FORTH primitives without name. +; Users can access them via declarations made in \inc\MSP430FRxxxx.pat +; +;############################################################################### +; ╦┌┐┌┌┬┐┌─┐┬─┐┬─┐┬ ┬┌─┐┌┬┐┌─┐ ┌─┐┌─┐┬ ┬ ┌┬┐┌─┐┬ ┬┌┐┌ ┬ ┬┌─┐┬─┐┌─┐ +; ║│││ │ ├┤ ├┬┘├┬┘│ │├─┘ │ └─┐ ├┤ ├─┤│ │ │││ │││││││ ├─┤├┤ ├┬┘├┤ +; ╩┘└┘ ┴ └─┘┴└─┴└─└─┘┴ ┴ └─┘ └ ┴ ┴┴─┘┴─┘ ─┴┘└─┘└┴┘┘└┘ ┴ ┴└─┘┴└─└─┘ +;############################################################################### +SLEEP +; here, FAST FORTH sleeps, waiting any interrupt. With LPM4, supply current is below 1uA. +; IP,S,T,W,X,Y registers (R13 to R8) are free... +; ...and so TOS, PSP and RSP stacks within their rules of use. +; remember: in any interrupt routine you must include : BIC #0xF8,0(RSP) before RETI to force SLEEP execution. +; or simply : ADD #2 RSP, then RET instead of RETI (but previous SR flags will be lost) + CALL @PC+ ; SLEEP first calls BACKGND_APP +PFASLEEP .word RXON ; BACKGND_DEF = RXON as default BACKGND_APP; value set by WIPE. + BIS &LPM_MODE,SR ; enter in LPMx mode with GIE=1 (after next instruction executing). + JMP SLEEP ; +; +;############################################################################### - .org PROGRAMSTART - -;------------------------------------------------------------------------------- -; DEFINING EXECUTIVE WORDS - DTC model -;------------------------------------------------------------------------------- - -;------------------------------------------------------------------------------- -; very nice FAST FORTH added feature: -;------------------------------------------------------------------------------- -; as IP is computed from the PC value, we can place low level to high level -; switches "COLON" or "LO2HI" anywhere in a word, i.e. not only at its beginning. -;------------------------------------------------------------------------------- - -RSP .reg R1 ; RSP = Return Stack Pointer (return stack) - -; DOxxx registers ; must be saved before use and restored after use -rDODOES .reg r4 -rDOCON .reg r5 -rDOVAR .reg r6 - -; Scratch registers -Y .reg R8 -X .reg R9 -W .reg R10 -T .reg R11 -S .reg R12 - -; Forth virtual machine -IP .reg R13 ; interpretative pointer -TOS .reg R14 ; first PSP cell -PSP .reg R15 ; PSP = Parameters Stack Pointer (stack data) - -mNEXT .MACRO ; return for low level words (written in assembler) - MOV @IP+,PC ; 4 fetch code address into PC, IP=PFA - .ENDM ; 4 cycles,1word = ITC -2cycles -1 word - -NEXT .equ 4D30h ; 4 MOV @IP+,PC - -FORTHtoASM .MACRO ; compiled by HI2LO - .word $+2 ; 0 cycle - .ENDM ; 0 cycle, 1 word - - - - .SWITCH DTC -;------------------------------------------------------------------------------- - .CASE 1 ; DOCOL = CALL rDOCOL -;------------------------------------------------------------------------------- - -rDOCOL .reg R7 ; COLD defines xdocol as R7 content - -xdocol MOV @RSP+,W ; 2 - PUSH IP ; 3 save old IP on return stack - MOV W,IP ; 1 set new IP to PFA - MOV @IP+,PC ; 4 = NEXT - ; 10 cycles - -ASMtoFORTH .MACRO ; compiled by LO2HI - CALL #EXIT ; 2 words, 10 cycles - .ENDM ; - -mDOCOL .MACRO ; compiled by : and by colon - CALL R7 ; 1 word, 14 cycles (CALL included) = ITC+4 - .ENDM ; - -DOCOL1 .equ 1287h ; 4 CALL R7 - -;------------------------------------------------------------------------------- - .CASE 2 ; DOCOL = PUSH IP + CALL rEXIT -;------------------------------------------------------------------------------- - -rEXIT .reg R7 ; COLD defines EXIT as R7 content - -ASMtoFORTH .MACRO ; compiled by LO2HI - CALL rEXIT ; 1 word, 10 cycles - .ENDM ; - -mDOCOL .MACRO ; compiled by : and by COLON - PUSH IP ; 3 - CALL rEXIT ; 10 - .ENDM ; 2 words, 13 cycles = ITC+3 - -DOCOL1 .equ 120Dh ; 3 PUSH IP -DOCOL2 .equ 1287h ; 4 CALL rEXIT - -;------------------------------------------------------------------------------- - .CASE 3 ; inlined DOCOL -;------------------------------------------------------------------------------- - -R .reg R7 ; Scratch register - -ASMtoFORTH .MACRO ; compiled by LO2HI - MOV PC,IP ; 1 - ADD #4,IP ; 1 - MOV @IP+,PC ; 4 NEXT - .ENDM ; 6 cycles, 3 words - -mDOCOL .MACRO ; compiled by : and by COLON - PUSH IP ; 3 - MOV PC,IP ; 1 - ADD #4,IP ; 1 - MOV @IP+,PC ; 4 NEXT - .ENDM ; 4 words, 9 cycles (ITC-1) - -DOCOL1 .equ 120Dh ; 3 PUSH IP -DOCOL2 .equ 400Dh ; 1 MOV PC,IP -DOCOL3 .equ 522Dh ; 1 ADD #4,IP - - .ENDCASE ; DTC - +; ------------------------------------------------------------------------------ +; COMPILING OPERATORS +; ------------------------------------------------------------------------------ +; Primitive LIT; compiled by LITERAL +; lit -- x fetch inline literal to stack +; This is the run-time code of LITERAL. +; FORTHWORD "LIT" +LIT SUB #2,PSP ; 2 push old TOS.. + MOV TOS,0(PSP) ; 3 ..onto stack + MOV @IP+,TOS ; 2 fetch new TOS value + MOV @IP+,PC ; 4 NEXT + +; Primitive XSQUOTE; compiled by SQUOTE +; (S") -- addr u run-time code to get address and length of a compiled string. +XSQUOTE SUB #4,PSP ; 1 -- x x TOS ; push old TOS on stack + MOV TOS,2(PSP) ; 3 -- TOS x x ; and reserve one cell on stack + MOV.B @IP+,TOS ; 2 -- x u ; u = lenght of string + MOV IP,0(PSP) ; 3 -- addr u IP is odd... + ADD TOS,IP ; 1 -- addr u IP=addr+u=addr(end_of_string) + BIT #1,IP ; 1 -- addr u IP=addr+u Carry set/clear if odd/even + ADDC #0,IP ; 1 -- addr u IP=addr+u aligned + MOV @IP+,PC ; 4 16~ + +; https://forth-standard.org/standard/core/HERE +; HERE -- addr returns memory ptr +HERE SUB #2,PSP + MOV TOS,0(PSP) + MOV &DDP,TOS + MOV @IP+,PC ;------------------------------------------------------------------------------- -; mDOVAR leave on parameter stack the PFA of a VARIABLE definition +; BRANCH run-time ;------------------------------------------------------------------------------- - -mDOVAR .MACRO ; compiled by VARIABLE - CALL rDOVAR ; 1 word, 14 cycles (ITC+4) - .ENDM ; - -DOVAR .equ 1286h ; CALL rDOVAR ; [rDOVAR] is defined as RFROM by COLD - +; Primitive QFBRAN; compiled by IF UNTIL +;Z ?FalseBranch x -- ; branch if TOS is FALSE (TOS = 0) +QFBRAN CMP #0,TOS ; 1 test TOS value + MOV @PSP+,TOS ; 2 pop new TOS value (doesn't change flags) + JNZ SKIPBRANCH ; 2 if TOS was <> 0, skip the branch; 10 cycles +; Primitive BRAN +;Z branch -- ; +BRAN MOV @IP,IP ; 2 take the branch destination + MOV @IP+,PC ; 4 ==> branch taken = 11 cycles ;------------------------------------------------------------------------------- -; mDOCON leave on parameter stack the [PFA] of a CONSTANT definition +; LOOP run-time ;------------------------------------------------------------------------------- +; Primitive XDO; compiled by DO +;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2 run-time code for DO +; n1|u1=limit, n2|u2=index +XDO MOV #8000h,X ;2 compute 8000h-limit = "fudge factor" + SUB @PSP+,X ;2 + MOV TOS,Y ;1 loop ctr = index+fudge + MOV @PSP+,TOS ;2 pop new TOS + ADD X,Y ;1 Y = INDEX + PUSHM #2,X ;4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX + MOV @IP+,PC ;4 + +; Primitive XPLOOP; compiled by +LOOP +;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2 +; run-time code for +LOOP +; Add n to the loop index. If loop terminates, clean up the +; return stack and skip the branch. Else take the inline branch. +XPLOOP ADD TOS,0(RSP) ;4 increment INDEX by TOS value + MOV @PSP+,TOS ;2 get new TOS, doesn't change flags +XLOOPNEXT BIT #100h,SR ;2 is overflow bit set? + JZ BRAN ;2 no overflow = loop + ADD #4,RSP ;1 empty RSP +SKIPBRANCH ADD #2,IP ;1 overflow = loop done, skip branch ofs + MOV @IP+,PC ;4 16~ taken or not taken xloop/loop + +; Primitive XLOOP; compiled by LOOP +;Z (loop) R: sys1 sys2 -- | sys1 sys2 +; run-time code for LOOP +; Add 1 to the loop index. If loop terminates, clean up the +; return stack and skip the branch. Else take the inline branch. +; Note that LOOP terminates when index=8000h. +XLOOP ADD #1,0(RSP) ;4 increment INDEX + JMP XLOOPNEXT ;2 -mDOCON .MACRO ; compiled by CONSTANT - CALL rDOCON ; 1 word, 16 cycles (ITC+4) - .ENDM ; - -DOCON .equ 1285h ; 4 CALL rDOCON ; [rDOCON] is defined as xdocon by COLD - -xdocon ; -- constant ; 4 for CALL rDOCON - SUB #2,PSP ; 1 - MOV TOS,0(PSP) ; 3 save TOS on parameters stack - MOV @RSP+,TOS ; 2 TOS = CFA address of master word CONSTANT - MOV @TOS,TOS ; 2 TOS = CONSTANT value - MOV @IP+,PC ; 4 execute next word - ; 16 = ITC (+4) - +; primitive MUSMOD; compiled by ?NUMBER UM/MOD ;------------------------------------------------------------------------------- -; mDODOES leave on parameter stack the PFA of a CREATE definition and execute Master word +; unsigned 32-BIT DiViDend : 16-BIT DIVisor --> 32-BIT QUOTient, 16-BIT REMainder ;------------------------------------------------------------------------------- +; 2 times faster if DVDhi = 0 (it's the general case) -mDODOES .MACRO ; compiled by DOES> - CALL rDODOES ; CALL xdodoes - .ENDM ; 1 word, 19 cycles (ITC-2) - -DODOES .equ 1284h ; 4 CALL rDODOES ; [rDODOES] is defind as xdodoes by COLD +; reg division MU/MOD NUM +; --------------------------------------------- +; S = DVD(15-0) = ud1lo = ud1lo +; TOS = DVD(31-16) = ud1hi = ud1hi +; T = DIV(15-0) = BASE +; W = DVD(47-32)/REM = rem = digit --> char --> -[HP] +; X = QUOTlo = ud2lo = ud2lo +; Y = QUOThi = ud2hi = ud2hi +; rDODOES = count -xdodoes ; -- a-addr ; 4 for CALL rDODOES - SUB #2,PSP ; 1 - MOV TOS,0(PSP) ; 3 save TOS on parameters stack - MOV @RSP+,TOS ; 2 TOS = CFA address of master word, i.e. address of its first cell after DOES> - PUSH IP ; 3 save IP on return stack - MOV @TOS+,IP ; 2 IP = CFA of Master word, TOS = BODY address of created word - MOV @IP+,PC ; 4 Execute Master word +MUSMOD MOV TOS,T ;1 T = DIVlo + MOV 2(PSP),S ;3 S = DVDlo + MOV @PSP,TOS ;2 TOS = DVDhi +MUSMOD1 MOV #0,W ;1 W = REMlo = 0 + MOV #32,rDODOES ;2 init loop count + CMP #0,TOS ;1 DVDhi=0 ? + JNZ MDIV1 ;2 no +; ----------------------------------------- +MDIV1DIV2 RRA rDODOES ;1 yes:loop count / 2 + MOV S,TOS ;1 DVDhi <-- DVDlo + MOV #0,S ;1 DVDlo <-- 0 + MOV #0,X ;1 QUOTlo <-- 0 (to do QUOThi = 0 at the end of division) +; ----------------------------------------- +MDIV1 CMP T,W ;1 REMlo U>= DIV ? + JNC MDIV2 ;2 no : carry is reset + SUB T,W ;1 yes: REMlo - DIV ; carry is set +MDIV2 ADDC X,X ;1 RLC quotLO + ADDC Y,Y ;1 RLC quotHI + SUB #1,rDODOES ;1 Decrement loop counter + JN ENDMDIV ;2 + ADD S,S ;1 RLA DVDlo + ADDC TOS,TOS ;1 RLC DVDhi + ADDC W,W ;1 RLC REMlo + JNC MDIV1 ;2 + SUB T,W ;1 REMlo - DIV + BIS #1,SR ;1 SETC + JMP MDIV2 ;2 +ENDMDIV MOV #XDODOES,rDODOES ;2 restore rDODOES + MOV W,2(PSP) ;3 REMlo in 2(PSP) + MOV X,0(PSP) ;3 QUOTlo in 0(PSP) + MOV Y,TOS ;1 QUOThi in TOS +RET_ADR MOV @RSP+,PC ;4 35 words, about 473 cycles, not FORTH executable ! + +; : SETIB SOURCE 2! 0 >IN ! ; +; SETIB org len -- set Input Buffer, shared by INTERPRET and [ELSE] +SETIB MOV TOS,&SOURCE_LEN ; -- org len + MOV @PSP+,&SOURCE_ORG ; -- len + MOV #0,&TOIN ; + MOV @PSP+,TOS ; -- + MOV @IP+,PC ; + +; REFILL accept one line to input buffer and leave org len' of the filled input buffer +; as it has no more host OS and as waiting command is done by ACCEPT, REFILL's flag is useless +; : REFILL TIB DUP TIB_LEN ACCEPT ; -- org len' shared by QUIT and [ELSE] +REFILL SUB #6,PSP ;2 + MOV TOS,4(PSP) ;3 + MOV #TIB_LEN,TOS ;2 -- x x len + .word 40BFh ; MOV #imm,index(PSP) +CIB_ADR .word TIB_ORG ; imm=TIB_ORG + .word 0 ;4 -- x org len index=0 ==> MOV #TIB_ORG,0(PSP) + MOV @PSP,2(PSP) ;4 -- org org len + JMP ACCEPT ;2 org org len -- org len' + +XDODOES ; -- addr ; 4 for CALL rDODOES S-- BODY PFA R-- + SUB #2,PSP ;+1 + MOV TOS,0(PSP) ;+3 save TOS on parameters stack + MOV @RSP+,TOS ;+2 TOS = PFA address of master word, i.e. address of its first cell after DOES> + PUSH IP ;+3 save IP on return stack + MOV @TOS+,IP ;+2 IP = CFA of Master word, TOS = BODY address of created word + MOV @IP+,PC ;+4 = 19~ = ITC-2 + +XDOCON ; 4 for CALL rDOCON S-- CTE PFA R-- + SUB #2,PSP ;+1 + MOV TOS,0(PSP) ;+3 save TOS on parameters stack + MOV @RSP+,TOS ;+2 TOS = PFA address of master word CONSTANT + MOV @TOS,TOS ;+2 TOS = CONSTANT value + MOV @IP+,PC ;+4 = 16~ = ITC+4 + +; https://forth-standard.org/standard/core/Rfrom +; R> -- x R: x -- pop from return stack +RFROM +XDOVAR ; 4 for CALL rDOVAR ADR -- VAR + SUB #2,PSP ;+1 + MOV TOS,0(PSP) ;+3 + MOV @RSP+,TOS ;+2 + MOV @IP+,PC ;+4 = 14~ = ITC+4 + +;-----------------------------------; +; RESET 6.1: init Forth engine ; common part of QABORT|RESET +;-----------------------------------; +INI_FORTH ; + CALL @PC+ ; +PFA_INI_FORTH + .IFNDEF SD_CARD_LOADER + .word RET_ADR ; INI_SOFT_DEF: default value, to do nothing + .ELSE + .word INI_FORTH_SD ; INI_SOFT_SD : close all handles, set default ACCEPT and TIB + .ENDIF + MOV #INI_FORTH_INI,X ; in FRAM INFO + MOV @X+,&PFAACCEPT ; BODYACCEPT --> PFAACCEPT + MOV @X+,&PFACR ; BODYCR --> PFACR + MOV @X+,&PFAEMIT ; BODYEMIT --> PFAEMIT + MOV @X+,&PFAKEY ; BODYKEY --> PFAKEY + MOV @X+,&CIB_ADR ; TIB_ORG --> CIB_ADR + MOV @X+,rDOCOL ; --> rDOCOL + MOV @X+,rDODOES ; xDODOES --> rDODOES + MOV @X+,rDOCON ; xDOCON --> rDOCON + MOV @X+,rDOVAR ; RFROM --> rDOVAR + MOV @X+,&CAPS ; 32 --> CAPS init CAPS ON + MOV @X+,&BASE ; 10 --> BASE init decimal base + MOV @RSP+,IP ; init IP with RET_ADR = LIT|WARM from resp. QABORT|RESET + MOV #SEL_P_R_D,PC ; goto RESET 6.2 to select PWR_STATE|RST_STATE|DEEP_RESET + +;------------------------------------------------------------------------------- +; SELECT TERMINAL: I2C_SLave, UART, HalfDuplex; ACCEPT KEY EMIT WIPE COLD WARM +;------------------------------------------------------------------------------- + .IFDEF TERMINAL_I2C + .include "forthMSP430FR_TERM_I2C.asm" + .ELSE + .IFDEF HALFDUPLEX + .include "forthMSP430FR_TERM_HALF.asm" + .ELSE + .include "forthMSP430FR_TERM_UART.asm" + .ENDIF + .ENDIF + .IFDEF SD_CARD_LOADER + .include "forthMSP430FR_SD_ACCEPT.asm" + .ENDIF -;------------------------------------------------------------------------------- -; INTERPRETER LOGIC -;------------------------------------------------------------------------------- + .IF DTC = 1 ; DOCOL = CALL rDOCOL, [rDOCOL] = xdocol +XDOCOL MOV @RSP+,W ; 2 + PUSH IP ; 3 save old IP on return stack + MOV W,IP ; 1 set new IP to PFA + MOV @IP+,PC ; 4 = NEXT + .ENDIF ; 10 cycles -;https://forth-standard.org/standard/core/EXIT -;C EXIT -- exit a colon definition; CALL #EXIT performs ASMtoFORTH (10 cycles) - FORTHWORD "EXIT" -EXIT: MOV @RSP+,IP ; 2 pop previous IP (or next PC) from return stack - MOV @IP+,PC ; 4 = NEXT - ; 6 = ITC - 2 + FORTHWORD "TYPE" +;https://forth-standard.org/standard/core/TYPE +;C TYPE adr len -- type string to terminal +TYPE CMP #0,TOS ;1 + JZ TWODROP ;2 abort fonction + PUSH IP ;3 + MOV #TYPE_NEXT,IP ;2 +TYPELOOP MOV @PSP,Y ;2 -- adr len Y = adr + SUB #2,PSP ;1 -- adr x len + MOV TOS,0(PSP) ;3 -- adr len len + MOV.B @Y+,TOS ;2 -- adr len char + MOV Y,2(PSP) ;3 -- adr+1 len char + MOV &PFAEMIT,PC ;5+17 all scratch registers must be and are free +TYPE_NEXT .word $+2 ; -- adr+1 len + SUB #2,IP ;1 [IP] = TYPE_NEXT + SUB #1,TOS ;1 -- adr+1 len-1 + JNZ TYPELOOP ;2 37~ EMIT loop + MOV @RSP+,IP ;3 -- adr+len 0 +TWODROP ADD #2,PSP ;1 -- 0 +DROP MOV @PSP+,TOS ;2 -- + MOV @IP+,PC ;4 -;Z lit -- x fetch inline literal to stack -; This is the primitive compiled by LITERAL. - FORTHWORD "LIT" -lit: SUB #2,PSP ; 2 push old TOS.. - MOV TOS,0(PSP) ; 3 ..onto stack - MOV @IP+,TOS ; 2 fetch new TOS value - MOV @IP+,PC ; 4 NEXT - ; 11 = ITC - 2 + FORTHWORD "CR" +; https://forth-standard.org/standard/core/CR +; CR -- send CR to the output device +CR MOV @PC+,PC ;3 Code Field Address (CFA) of CR +PFACR .word BODYCR ; Parameter Field Address (PFA) of CR, with its default value +BODYCR mDOCOL ; send CR+LF to the default output device + .word XSQUOTE + .byte 2,13,10 + .word TYPE,EXIT ;------------------------------------------------------------------------------- ; STACK OPERATIONS ;------------------------------------------------------------------------------- - -;https://forth-standard.org/standard/core/DUP -;C DUP x -- x x duplicate top of stack + .IFDEF CORE_COMPLEMENT FORTHWORD "DUP" -DUP: SUB #2,PSP ; 2 push old TOS.. - MOV TOS,0(PSP) ; 3 ..onto stack - mNEXT ; 4 + .ENDIF +; https://forth-standard.org/standard/core/DUP +; DUP x -- x x duplicate top of stack +DUP SUB #2,PSP ; 2 push old TOS.. + MOV TOS,0(PSP) ; 3 ..onto stack + MOV @IP+,PC ; 4 -;https://forth-standard.org/standard/core/qDUP -;C ?DUP x -- 0 | x x DUP if nonzero + .IFDEF CORE_COMPLEMENT FORTHWORD "?DUP" -QDUP: CMP #0,TOS ; 2 test for TOS nonzero - JNZ DUP ; 2 - mNEXT ; 4 - -;https://forth-standard.org/standard/core/DROP -;C DROP x -- drop top of stack + .ENDIF +; https://forth-standard.org/standard/core/qDUP +; ?DUP x -- 0 | x x DUP if nonzero +QDUP CMP #0,TOS ; 2 test for TOS nonzero + JNZ DUP ; 2 + MOV @IP+,PC ; 4 + + .IFDEF CORE_COMPLEMENT + FORTHWORD "2DUP" + .ENDIF +; https://forth-standard.org/standard/core/TwoDUP +; 2DUP x1 x2 -- x1 x2 x1 x2 dup top 2 cells +TWODUP MOV TOS,-2(PSP) ; 3 + MOV @PSP,-4(PSP); 4 + SUB #4,PSP ; 1 + MOV @IP+,PC ; 4 + + .IFDEF CORE_COMPLEMENT + FORTHWORD "SWAP" + .ENDIF +; https://forth-standard.org/standard/core/SWAP +; SWAP x1 x2 -- x2 x1 swap top two items +SWAP MOV @PSP,W ; 2 + MOV TOS,0(PSP) ; 3 + MOV W,TOS ; 1 + MOV @IP+,PC ; 4 + + .IFDEF CORE_COMPLEMENT FORTHWORD "DROP" -DROP: MOV @PSP+,TOS ; 2 - mNEXT ; 4 - -;https://forth-standard.org/standard/core/NIP -;C NIP x1 x2 -- x2 Drop the first item below the top of stack +; https://forth-standard.org/standard/core/DROP +; DROP x -- drop top of stack + MOV @PSP+,TOS ; 2 + MOV @IP+,PC ; 4 + FORTHWORD "NIP" -NIP: ADD #2,PSP ; 1 - mNEXT ; 4 - -;https://forth-standard.org/standard/core/SWAP -;C SWAP x1 x2 -- x2 x1 swap top two items - FORTHWORD "SWAP" -SWAP: MOV @PSP,W ; 2 - MOV TOS,0(PSP) ; 3 - MOV W,TOS ; 1 - mNEXT ; 4 +; https://forth-standard.org/standard/core/NIP +; NIP x1 x2 -- x2 Drop the first item below the top of stack + ADD #2,PSP ; 1 + MOV @IP+,PC ; 4 + .IFNDEF OVER + FORTHWORD "OVER" ;https://forth-standard.org/standard/core/OVER ;C OVER x1 x2 -- x1 x2 x1 - FORTHWORD "OVER" -OVER: MOV TOS,-2(PSP) ; 3 -- x1 (x2) x2 - MOV @PSP,TOS ; 2 -- x1 (x2) x1 - SUB #2,PSP ; 2 -- x1 x2 x1 - mNEXT ; 4 + MOV TOS,-2(PSP) ; 3 -- x1 (x2) x2 + MOV @PSP,TOS ; 2 -- x1 (x2) x1 + SUB #2,PSP ; 1 -- x1 x2 x1 + MOV @IP+,PC ; 4 + .ENDIF + FORTHWORD "ROT" ;https://forth-standard.org/standard/core/ROT ;C ROT x1 x2 x3 -- x2 x3 x1 - FORTHWORD "ROT" -ROT: MOV @PSP,W ; 2 fetch x2 - MOV TOS,0(PSP) ; 3 store x3 - MOV 2(PSP),TOS ; 3 fetch x1 - MOV W,2(PSP) ; 3 store x2 - mNEXT ; 4 - -;https://forth-standard.org/standard/core/toR -;C >R x -- R: -- x push to return stack - FORTHWORD ">R" -TOR: PUSH TOS - MOV @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/Rfrom -;C R> -- x R: x -- pop from return stack ; CALL #RFROM performs DOVAR - FORTHWORD "R>" -RFROM: SUB #2,PSP ; 1 - MOV TOS,0(PSP) ; 3 - MOV @RSP+,TOS ; 2 - mNEXT ; 4 + MOV @PSP,W ; 2 fetch x2 + MOV TOS,0(PSP) ; 3 store x3 + MOV 2(PSP),TOS ; 3 fetch x1 + MOV W,2(PSP) ; 3 store x2 + MOV @IP+,PC ; 4 + FORTHWORD "DEPTH" + .ENDIF +; https://forth-standard.org/standard/core/DEPTH +; DEPTH -- +n number of items on stack, must leave 0 if stack empty +DEPTH MOV TOS,-2(PSP) + MOV #PSTACK,TOS + SUB PSP,TOS ; PSP-S0--> TOS + RRA TOS ; TOS/2 --> TOS + SUB #2,PSP ; post decrement stack... + MOV @IP+,PC + + .IFDEF CORE_COMPLEMENT + FORTHWORD "R@" ;https://forth-standard.org/standard/core/RFetch ;C R@ -- x R: x -- x fetch from rtn stk - FORTHWORD "R@" -RFETCH: SUB #2,PSP - MOV TOS,0(PSP) - MOV @RSP,TOS - mNEXT + SUB #2,PSP + MOV TOS,0(PSP) + MOV @RSP,TOS + MOV @IP+,PC -;https://forth-standard.org/standard/core/DEPTH -;C DEPTH -- +n number of items on stack, must leave 0 if stack empty - FORTHWORD "DEPTH" -DEPTH: MOV TOS,-2(PSP) - MOV #PSTACK,TOS - SUB PSP,TOS ; PSP-S0--> TOS - SUB #2,PSP ; post decrement stack... - RRA TOS ; TOS/2 --> TOS - mNEXT + FORTHWORD ">R" +; https://forth-standard.org/standard/core/toR +; >R x -- R: -- x push to return stack +TOR PUSH TOS + MOV @PSP+,TOS + MOV @IP+,PC + + FORTHWORD "R>" +; https://forth-standard.org/standard/core/Rfrom +; R> -- x R: x -- pop from return stack + SUB #2,PSP ; 1 + MOV TOS,0(PSP) ; 3 + MOV @RSP+,TOS ; 2 + MOV @IP+,PC ; 4 + .ENDIF ;------------------------------------------------------------------------------- -; MEMORY OPERATIONS +; ARITHMETIC OPERATIONS ;------------------------------------------------------------------------------- + .IFDEF CORE_COMPLEMENT + FORTHWORD "1+" +; https://forth-standard.org/standard/core/OnePlus +; 1+ n1/u1 -- n2/u2 add 1 to TOS + ADD #1,TOS + MOV @IP+,PC -;https://forth-standard.org/standard/core/Fetch -;C @ a-addr -- x fetch cell from memory - FORTHWORD "@" -FETCH: MOV @TOS,TOS - mNEXT - -;https://forth-standard.org/standard/core/Store -;C ! x a-addr -- store cell in memory - FORTHWORD "!" -STORE: MOV @PSP+,0(TOS) ;4 - MOV @PSP+,TOS ;2 - mNEXT ;4 + FORTHWORD "1-" +; https://forth-standard.org/standard/core/OneMinus +; 1- n1/u1 -- n2/u2 subtract 1 from TOS + SUB #1,TOS + MOV @IP+,PC -;https://forth-standard.org/standard/core/CFetch -;C C@ c-addr -- char fetch char from memory - FORTHWORD "C@" -CFETCH: MOV.B @TOS,TOS ;2 - mNEXT ;4 + FORTHWORD "+" +;https://forth-standard.org/standard/core/Plus +;C + n1/u1 n2/u2 -- n3/u3 add n1+n2 + ADD @PSP+,TOS + MOV @IP+,PC -;https://forth-standard.org/standard/core/CStore -;C C! char c-addr -- store char in memory - FORTHWORD "C!" -CSTORE: MOV.B @PSP+,0(TOS);4 - ADD #1,PSP ;1 - MOV @PSP+,TOS ;2 - mNEXT + FORTHWORD "-" + .ENDIF +; https://forth-standard.org/standard/core/Minus +; - n1/u1 n2/u2 -- n3/u3 n3 = n1-n2 +MINUS SUB @PSP+,TOS ;2 -- n2-n1 +NEGATE XOR #-1,TOS ;1 +ONEPLUS ADD #1,TOS ;1 -- n3 = -(n2-n1) = n1-n2 + MOV @IP+,PC ;------------------------------------------------------------------------------- -; ARITHMETIC OPERATIONS +; MEMORY OPERATIONS ;------------------------------------------------------------------------------- + FORTHWORD "@" +; https://forth-standard.org/standard/core/Fetch +; @ a-addr -- x fetch cell from memory +FETCH MOV @TOS,TOS + MOV @IP+,PC -;https://forth-standard.org/standard/core/Plus -;C + n1/u1 n2/u2 -- n3/u3 add n1+n2 - FORTHWORD "+" -PLUS: ADD @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/Minus -;C - n1/u1 n2/u2 -- n3/u3 n3 = n1-n2 - FORTHWORD "-" -MINUS: SUB @PSP+,TOS ;2 -- n2-n1 -NEGATE: XOR #-1,TOS ;1 -ONEPLUS: ADD #1,TOS ;1 -- n3 = -(n2-n1) - mNEXT - -;https://forth-standard.org/standard/core/AND -;C AND x1 x2 -- x3 logical AND - FORTHWORD "AND" -ANDD: AND @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/OR -;C OR x1 x2 -- x3 logical OR - FORTHWORD "OR" -ORR: BIS @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/XOR -;C XOR x1 x2 -- x3 logical XOR - FORTHWORD "XOR" -XORR: XOR @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/NEGATE -;C NEGATE x1 -- x2 two's complement - FORTHWORD "NEGATE" - JMP NEGATE - -;https://forth-standard.org/standard/core/ABS -;C ABS n1 -- +n2 absolute value - FORTHWORD "ABS" -ABBS: CMP #0,TOS ; 1 - JN NEGATE - mNEXT - -;https://forth-standard.org/standard/double/DABS -;C DABS d1 -- |d1| absolute value - FORTHWORD "DABS" -DABBS: AND #-1,TOS ; clear V, set N - JGE DABBSEND ; JMP if positive -DNEGATE: XOR #-1,0(PSP) - XOR #-1,TOS - ADD #1,0(PSP) - ADDC #0,TOS -DABBSEND mNEXT + FORTHWORD "!" +; https://forth-standard.org/standard/core/Store +; ! x a-addr -- store cell in memory +STORE MOV @PSP+,0(TOS);4 + MOV @PSP+,TOS ;2 + MOV @IP+,PC ;4 ;------------------------------------------------------------------------------- ; COMPARAISON OPERATIONS ;------------------------------------------------------------------------------- - -;https://forth-standard.org/standard/core/ZeroEqual -;C 0= n/u -- flag return true if TOS=0 + .IFDEF CORE_COMPLEMENT FORTHWORD "0=" -ZEROEQUAL: SUB #1,TOS ; borrow (clear cy) if TOS was 0 - SUBC TOS,TOS ; TOS=-1 if borrow was set - mNEXT + .ENDIF +; https://forth-standard.org/standard/core/ZeroEqual +; 0= n/u -- flag return true if TOS=0 +ZEROEQUAL SUB #1,TOS ;1 borrow (clear cy) if TOS was 0 + SUBC TOS,TOS ;1 TOS=-1 if borrow was set + MOV @IP+,PC ;4 -;https://forth-standard.org/standard/core/Zeroless -;C 0< n -- flag true if TOS negative + .IFDEF CORE_COMPLEMENT FORTHWORD "0<" -ZEROLESS: ADD TOS,TOS ;1 set carry if TOS negative - SUBC TOS,TOS ;1 TOS=-1 if carry was clear - XOR #-1,TOS ;1 TOS=-1 if carry was set - mNEXT - -;https://forth-standard.org/standard/core/Zeromore -;C 0> n -- flag true if TOS positive - FORTHWORD "0>" -ZEROMORE: CMP #1,TOS - JGE TOSTRUE - JMP TOSFALSE - -;https://forth-standard.org/standard/core/Equal -;C = x1 x2 -- flag test x1=x2 + .ENDIF +; https://forth-standard.org/standard/core/Zeroless +; 0< n -- flag true if TOS negative +ZEROLESS ADD TOS,TOS ;1 set carry if TOS negative + SUBC TOS,TOS ;1 TOS=-1 if carry was clear +INVERT XOR #-1,TOS ;1 TOS=-1 if carry was set + MOV @IP+,PC ; + + .IFDEF CORE_COMPLEMENT + FORTHWORD "U<" + .ENDIF +; https://forth-standard.org/standard/core/Uless +; U< u1 u2 -- flag test u1" ;https://forth-standard.org/standard/core/more ;C > n1 n2 -- flag test n1>n2, signed - FORTHWORD ">" -GREATER: SUB @PSP+,TOS ;2 TOS=n2-n1 - JL TOSTRUE ;2 - MOV #0,TOS ;1 - mNEXT ;4 - -;https://forth-standard.org/standard/core/Uless -;C U< u1 u2 -- flag test u1 branch not taken = 10 cycles - -;Z 0?branch x -- branch if TOS <> zero -QZBRAN: SUB #1,TOS ; 1 borrow (clear cy) if TOS was 0 - SUBC TOS,TOS ; 1 TOS=-1 if borrow was set - JMP QBRAN1 ; 2 - - -;Z (do) n1|u1 n2|u2 -- R: -- sys1 sys2 run-time code for DO -; n1|u1=limit, n2|u2=index -xdo: MOV #8000h,X ;2 compute 8000h-limit "fudge factor" - SUB @PSP+,X ;2 - MOV TOS,Y ;1 loop ctr = index+fudge - MOV @PSP+,TOS ;2 pop new TOS - ADD X,Y ;1 - .word 01519h ;4 PUSHM X,Y, i.e. PUSHM LIMIT, INDEX - mNEXT ;4 - -;Z (+loop) n -- R: sys1 sys2 -- | sys1 sys2 -; run-time code for +LOOP -; Add n to the loop index. If loop terminates, clean up the -; return stack and skip the branch. Else take the inline branch. -xploop: ADD TOS,0(RSP) ;4 increment INDEX by TOS value - MOV @PSP+,TOS ;2 get new TOS, doesn't change flags -xloopnext BIT #100h,SR ;2 is overflow bit set? - JZ bran ;2 no overflow = loop - ADD #2,IP ;1 overflow = loop done, skip branch ofs -UNXLOOP ADD #4,RSP ;1 empty RSP - mNEXT ;4 16~ taken or not taken xloop/loop - - -;Z (loop) R: sys1 sys2 -- | sys1 sys2 -; run-time code for LOOP -; Add 1 to the loop index. If loop terminates, clean up the -; return stack and skip the branch. Else take the inline branch. -; Note that LOOP terminates when index=8000h. -xloop: ADD #1,0(RSP) ;4 increment INDEX - JMP xloopnext ;2 - -;https://forth-standard.org/standard/core/UNLOOP -;C UNLOOP -- R: sys1 sys2 -- drop loop parms - FORTHWORD "UNLOOP" -UNLOOP: JMP UNXLOOP - -;https://forth-standard.org/standard/core/I -;C I -- n R: sys1 sys2 -- sys1 sys2 -;C get the innermost loop index - FORTHWORD "I" -II: SUB #2,PSP ;1 make room in TOS - MOV TOS,0(PSP) ;3 - MOV @RSP,TOS ;2 index = loopctr - fudge - SUB 2(RSP),TOS ;3 - mNEXT ;4 13~ - -;https://forth-standard.org/standard/core/J -;C J -- n R: 4*sys -- 4*sys -;C get the second loop index - FORTHWORD "J" -JJ: SUB #2,PSP ; make room in TOS - MOV TOS,0(PSP) - MOV 4(RSP),TOS ; index = loopctr - fudge - SUB 6(RSP),TOS - mNEXT - -;------------------------------------------------------------------------------- -; SYSTEM VARIABLES & CONSTANTS -;------------------------------------------------------------------------------- - -;https://forth-standard.org/standard/core/PAD -; PAD -- pad address - FORTHWORD "PAD" -PAD mDOCON - .WORD PAD_ORG - -; TIB -- terminal input buffer address - FORTHWORD "TIB" -TIB mDOCON - .WORD TIB_ORG ; constant, may be modified by IS - -; CPL -- terminal input buffer lenght (CPL = Chars Per Line) - FORTHWORD "CPL" -CPL mDOCON - .WORD TIB_LEN ; constant, may be modified by IS - -;https://forth-standard.org/standard/core/toIN -;C >IN -- a-addr holds offset in input stream - FORTHWORD ">IN" -FTOIN: mDOCON - .word TOIN ; VARIABLE address in RAM space - -;https://forth-standard.org/standard/core/BASE -;C BASE -- a-addr holds conversion radix - FORTHWORD "BASE" -FBASE: mDOCON - .word BASE ; VARIABLE address in RAM space - -;https://forth-standard.org/standard/core/STATE -;C STATE -- a-addr holds compiler state - FORTHWORD "STATE" -FSTATE: mDOCON - .word STATE ; VARIABLE address in RAM space - -;https://forth-standard.org/standard/core/BL -;C BL -- char an ASCII space - FORTHWORD "BL" -FBLANK: mDOCON - .word 32 - -;------------------------------------------------------------------------------- -; MULTIPLY -;------------------------------------------------------------------------------- - - .IFNDEF MPY ; if no hardware MPY - -; T.I. SIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud - -;https://forth-standard.org/standard/core/UMTimes -;C UM* u1 u2 -- ud unsigned 16x16->32 mult. - FORTHWORD "UM*" -UMSTAR: MOV @PSP,S ;2 U1 = MULTIPLICANDlo - MOV #0,W ;1 0 -> created MULTIPLICANDhi - MOV #0,Y ;1 0 -> created RESULTlo - MOV #0,T ;1 0 -> created RESULThi - MOV #1,X ;1 BIT TEST REGISTER -UMSTARLOOP BIT X,TOS ;1 TEST ACTUAL BIT MULTIPLIER - JZ UMSTARNEXT ;2 IF 0: DO NOTHING - ADD S,Y ;1 IF 1: ADD MULTIPLICAND TO RESULT - ADDC W,T ;1 -UMSTARNEXT ADD S,S ;1 (RLA LSBs) MULTIPLICAND x 2 - ADDC W,W ;1 (RLC MSBs) - ADD X,X ;1 (RLA) NEXT BIT TO TEST - JNC UMSTARLOOP ;2 IF BIT IN CARRY: FINISHED 10~ loop - MOV Y,0(PSP) ;3 low result on stack - MOV T,TOS ;1 high result in TOS - mNEXT - - .ENDIF ; no hardware MPY - -;------------------------------------------------------------------------------- -; ANS complement OPTION -;------------------------------------------------------------------------------- - .IFDEF ANS_CORE_COMPLIANT - .include "ADDON\ANS_COMPLEMENT.asm" - .ELSEIF - -;------------------------------------------------------------------------------- -; ALIGNMENT OPERATORS OPTION -;------------------------------------------------------------------------------- - .IFDEF ALIGNMENT ; included in ANS_COMPLEMENT - .include "ADDON\ALIGNMENT.asm" - .ENDIF ; ALIGNMENT + SUB @PSP+,TOS ;2 TOS=n2-n1 + JL TOSTRUE ;2 --> +5 +TOSFALSE AND #0,TOS ;1 flag Z = 1 + MOV @IP+,PC ;4 ;------------------------------------------------------------------------------- -; PORTABILITY OPERATORS OPTION +; CORE ANS94 complement OPTION ;------------------------------------------------------------------------------- - .IFDEF PORTABILITY - .include "ADDON\PORTABILITY.asm" - .ENDIF ; PORTABILITY - -;------------------------------------------------------------------------------- -; ARITHMETIC OPERATORS OPTION -;------------------------------------------------------------------------------- - .IFDEF ARITHMETIC ; included in ANS_COMPLEMENT - .include "ADDON\ARITHMETIC.asm" - .ENDIF ; ARITHMETIC - -;------------------------------------------------------------------------------- -; DOUBLE OPERATORS OPTION -;------------------------------------------------------------------------------- - .IFDEF DOUBLE ; included in ANS_COMPLEMENT - .include "ADDON\DOUBLE.asm" - .ENDIF ; DOUBLE - - .ENDIF ; ANS_COMPLEMENT + .include "ADDON/CORE_ANS.asm" + .ENDIF ; CORE_COMPLEMENT ;------------------------------------------------------------------------------- ; NUMERIC OUTPUT ;------------------------------------------------------------------------------- - ; Numeric conversion is done last digit first, so ; the output buffer is built backwards in memory. -;https://forth-standard.org/standard/core/num-start -;C <# -- begin numeric conversion (initialize Hold Pointer) FORTHWORD "<#" -LESSNUM: MOV #BASE_HOLD,&HP - mNEXT - -; unsigned 32-BIT DIVIDEND : 16-BIT DIVISOR --> 32-BIT QUOTIENT, 16-BIT REMAINDER -; DVDhi|DVDlo : DIVlo --> QUOThi|QUOTlo REMlo -; then REMlo is converted in ASCII char -; 2 times faster if DVDhi = 0 (it's the general case) - -; Input: division NUM -; ----------------------------- -; S = DVDlo (15-0) = ud1lo -; TOS = DVDhi (31-16) = ud1hi -; W = REMAINDER(15-0) -; T = DIVlo = BASE -; rDODOES = count - -; Output: division NUM -; ----------------------------- -; X = QUOTlo = ud2lo -; Y = QUOThi = ud2hi -; W = REMlo = digit --> char --> -[HP] +; https://forth-standard.org/standard/core/num-start +; <# -- begin numeric conversion (initialize Hold Pointer) +LESSNUM MOV #HOLD_BASE,&HP + MOV @IP+,PC -;https://forth-standard.org/standard/core/num -;C # ud1lo ud1hi -- ud2lo ud2hi convert 1 digit of output FORTHWORD "#" -NUM MOV @PSP,S ;2 TOS = DVDhi, S = DVDlo - MOV.B &BASE,T ;3 T = DIVlo - MOV #0,W ;1 W = REMlo = 0 - MOV #32,rDODOES ;2 init loop count - CMP #0,TOS ;1 DVDhi <> 0 ? - JNZ MDIV1 ;2 yes - RRA rDODOES ;1 no: loop count / 2 - MOV S,TOS ;1 DVDhi <-- DVDlo - MOV #0,S ;1 DVDlo <-- 0 - MOV #0,X ;1 QUOTlo <-- 0 (to do QUOThi = 0 at the end of division) -MDIV1: CMP T,W ;1 REMlo U>= DIVlo ? - JNC MDIV2 ;2 no - SUB T,W ;1 REMlo - DIVlo -MDIV2: ADDC X,X ;1 RLC QUOTlo - ADDC Y,Y ;1 RLC QUOThi - SUB #1,rDODOES ;1 Decrement loop counter - JN ENDMDIV ;2 If 0< --> end - ADD S,S ;1 RLA DVDlo - ADDC TOS,TOS ;1 RLC DVDhi - ADDC W,W ;1 RLC REMlo - JNC MDIV1 ;2 14~ loop - SUB T,W ;1 REMlo - DIVlo - BIS #1,SR ;1 SETC - JMP MDIV2 ;2 14~ loop -ENDMDIV MOV #xdodoes,rDODOES;2 restore rDODOES - MOV X,0(PSP) ;3 QUOTlo in 0(PSP) - MOV Y,TOS ;1 QUOThi in TOS -TODIGIT CMP.B #10,W ;2 W = REMlo - JLO TODIGIT1 ;2 U< - ADD #7,W ;2 -TODIGIT1 ADD #30h,W ;2 -HOLDW SUB #1,&HP ;3 store W=char --> -[HP] - MOV &HP,Y ;3 - MOV.B W,0(Y) ;3 - mNEXT ;4 45 words, about 270/492 cycles/char - -;https://forth-standard.org/standard/core/numS -;C #S udlo:udhi -- udlo:udhi=0 convert remaining digits +; https://forth-standard.org/standard/core/num +; # ud1lo ud1hi -- ud2lo ud2hi convert 1 digit of output +NUM MOV &BASE,T ;3 T = Divisor +NUM1 MOV @PSP,S ;2 -- DVDlo DVDhi S = DVDlo + SUB #2,PSP ;1 -- x x DVDhi TOS = DVDhi + CALL #MUSMOD1 ;4 -- REMlo QUOTlo QUOThi T is unchanged + MOV @PSP+,0(PSP) ;4 -- QUOTlo QUOThi +TODIGIT CMP.B #10,W ;2 W = REMlo + JNC TODIGIT1 ;2 jump if U< + ADD.B #7,W ;2 +TODIGIT1 ADD.B #30h,W ;2 +HOLDW SUB #1,&HP ;4 store W=char --> -[HP] + MOV &HP,Y ;3 + MOV.B W,0(Y) ;3 + MOV @IP+,PC ;4 23 words + FORTHWORD "#S" -NUMS: mDOCOL - .word NUM ; - FORTHtoASM ; - SUB #2,IP ;1 restore NUM return - CMP #0,X ;1 test ud2lo first (generally true) - JNZ NUM ;2 - CMP #0,TOS ;1 then test ud2hi (generally false) - JNZ NUM ;2 - MOV @RSP+,IP ;2 - mNEXT ;4 about 280/505 cycles/char - -;https://forth-standard.org/standard/core/num-end -;C #> udlo:udhi=0 -- c-addr u end conversion, get string +; https://forth-standard.org/standard/core/numS +; #S udlo udhi -- 0 0 convert remaining digits +NUMS mDOCOL + .word NUM ; X=QUOTlo +NUM_RETURN .word $+2 ; next adr + SUB #2,IP ;1 restore NUM return + CMP #0,X ;1 test ud2lo first (generally <>0) + JNZ NUM1 ;2 + CMP #0,TOS ;1 then test ud2hi (generally =0) + JNZ NUM1 ;2 +EXIT MOV @RSP+,IP + MOV @IP+,PC ;6 10 words, about 241/417 cycles/char + FORTHWORD "#>" -NUMGREATER: MOV &HP,0(PSP) - MOV #BASE_HOLD,TOS - SUB @PSP,TOS - mNEXT +; https://forth-standard.org/standard/core/num-end +; #> udlo:udhi -- c-addr u end conversion, get string +NUMGREATER MOV &HP,0(PSP) + MOV #HOLD_BASE,TOS + SUB @PSP,TOS + MOV @IP+,PC -;https://forth-standard.org/standard/core/HOLD -;C HOLD char -- add char to output string FORTHWORD "HOLD" -HOLD: MOV TOS,W ;1 - MOV @PSP+,TOS ;2 - JMP HOLDW ;15 +; https://forth-standard.org/standard/core/HOLD +; HOLD char -- add char to output string +HOLD MOV.B TOS,W ;1 + MOV @PSP+,TOS ;2 + JMP HOLDW ;15 -;https://forth-standard.org/standard/core/SIGN -;C SIGN n -- add minus sign if n<0 FORTHWORD "SIGN" -SIGN: CMP #0,TOS - MOV @PSP+,TOS - MOV #'-',W - JN HOLDW ; 0< - mNEXT - -;https://forth-standard.org/standard/core/Ud -;C U. u -- display u (unsigned) +; https://forth-standard.org/standard/core/SIGN +; SIGN n -- add minus sign if n<0 +SIGN CMP #0,TOS + MOV @PSP+,TOS + MOV.B #'-',W + JN HOLDW ; jump if 0< + MOV @IP+,PC + FORTHWORD "U." -UDOT: mDOCOL - .word LESSNUM,lit,0,NUMS,NUMGREATER,TYPE,SPACE,EXIT - -;https://forth-standard.org/standard/double/Dd -;C D. dlo dhi -- display d (signed) - FORTHWORD "D." -DDOT: mDOCOL - .word LESSNUM,SWAP,OVER,DABBS,NUMS - .word ROT,SIGN,NUMGREATER,TYPE,SPACE,EXIT - -;https://forth-standard.org/standard/core/d -;C . n -- display n (signed) +; https://forth-standard.org/standard/core/Ud +; U. u -- display u (unsigned) +; note: DDOT = UDOT + 10 +UDOT MOV #0,Y ; 1 +DOTTODDOT SUB #2,PSP ; 1 convert n|u to d|ud with Y = -1|0 + MOV TOS,0(PSP) ; 3 + MOV Y,TOS ; 1 +DDOT PUSH IP ; paired with EXIT R-- IP + PUSH TOS ; paired with RFROM R-- IP sign + AND #-1,TOS ; clear V, set N + JGE DDOTNEXT ; if positive (N=0) + XOR #-1,0(PSP) ;4 + XOR #-1,TOS ;1 + ADD #1,0(PSP) ;4 + ADDC #0,TOS ;1 +DDOTNEXT ASMTOFORTH ;10 + .word LESSNUM,NUMS + .word RFROM,SIGN,NUMGREATER,TYPE + .word FBLANK,EMIT,EXIT + FORTHWORD "." -DOT: CMP #0,TOS +; https://forth-standard.org/standard/core/d +; . n -- display n (signed) +DOT CMP #0,TOS JGE UDOT - SUB #2,PSP - MOV TOS,0(PSP) - MOV #-1,TOS ; extend sign - JMP DDOT - -;------------------------------------------------------------------------------- -; DICTIONARY MANAGEMENT -;------------------------------------------------------------------------------- - -;https://forth-standard.org/standard/core/HERE -;C HERE -- addr returns dictionary ptr - FORTHWORD "HERE" -HERE: SUB #2,PSP - MOV TOS,0(PSP) - MOV &DDP,TOS - mNEXT - -;https://forth-standard.org/standard/core/ALLOT -;C ALLOT n -- allocate n bytes in dict - FORTHWORD "ALLOT" -ALLOT: ADD TOS,&DDP - MOV @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/CComma -;C C, char -- append char to dict - FORTHWORD "C," -CCOMMA: MOV &DDP,W - MOV.B TOS,0(W) - ADD #1,&DDP - MOV @PSP+,TOS - mNEXT - -; ------------------------------------------------------------------------------ -; TERMINAL I/O, input part -; ------------------------------------------------------------------------------ - -;Z (KEY?) -- c get character from the terminal -; FORTHWORD "(KEY?)" -PARENKEYTST: SUB #2,PSP ; 1 push old TOS.. - MOV TOS,0(PSP) ; 4 ..onto stack - CALL #RXON -KEYLOOP BIT #UCRXIFG,&TERMIFG ; loop if bit0 = 0 in interupt flag register - JZ KEYLOOP ; - MOV &TERMRXBUF,TOS ; - CALL #RXOFF ; - mNEXT - -;F KEY? -- c get character from input device ; deferred word -; FORTHWORD "KEY?" -;KEYTST: MOV #PARENKEYTST,PC - - -;Z (KEY) -- c get character from the terminal - FORTHWORD "(KEY)" -PARENKEY: MOV &TERMRXBUF,Y ; empty buffer - JMP PARENKEYTST - -;https://forth-standard.org/standard/core/KEY -;C KEY -- c wait character from input device ; deferred word - FORTHWORD "KEY" -KEY: MOV #PARENKEY,PC - -;------------------------------------------------------------------------------- -; INTERPRETER INPUT, the kernel of kernel ! -;------------------------------------------------------------------------------- - - .IFDEF SD_CARD_LOADER - .include "forthMSP430FR_SD_ACCEPT.asm" ; that creates SD_ACCEPT - .ENDIF ; SD_CARD_LOADER - - -;https://forth-standard.org/standard/core/ACCEPT -;C ACCEPT addr addr len -- addr' len' get line at addr to interpret len' chars - FORTHWORD "ACCEPT" -ACCEPT MOV #PARENACCEPT,PC - -;C (ACCEPT) addr addr len -- addr len' get len' (up to len) chars from terminal (TERATERM.EXE) via USBtoUART bridge - FORTHWORD "(ACCEPT)" -PARENACCEPT - -; con speed of TERMINAL link, there are three bottlenecks : -; 1- time to send XOFF/RTS_high on CR (CR+LF=EOL), first emergency. -; 2- the char loop time, -; 3- the time between sending XON/RTS_low and clearing UCRXIFG on first received char, -; everything must be done to reduce these times, taking into account the necessity of switching to SLEEP (LPMx mode). -; --------------------------------------; -; (ACCEPT) part I: prepare TERMINAL_INT ; -; --------------------------------------; - MOV #ENDACCEPT,S ;2 S = ACCEPT XOFF return - MOV #AKEYREAD1,T ;2 T = default XON return -; .word 1537h ;6 in advance, we can also save R7 to R4 - .word 152Dh ;5 PUSHM IP,S,T, as IP ret, XOFF ret, XON ret - MOV TOS,W ;1 -- addr len - MOV @PSP,TOS ;2 -- org ptr ) - ADD TOS,W ;1 -- org ptr W=Bound ) - MOV #0Dh,T ;2 T = 'CR' to speed up char loop in part II > prepare stack and registers - MOV #20h,S ;2 S = 'BL' to speed up char loop in part II ) for TERMINAL_INT use - MOV #AYEMIT_RET,IP ;2 IP = return for YEMIT ) - BIT #UCRXIFG,&TERMIFG ;3 RX_Int ? - JZ ACCEPTNEXT ;2 no : case of quiet input terminal - MOV &TERMRXBUF,Y ;3 yes: clear RX_Int - CMP #0Ah,Y ;2 received char = LF ? (end of downloading ?) - JNZ RXON ;2 no : RXON return = AKEYREAD1, to process first char of new line. -ACCEPTNEXT ADD #2,RSP ;1 yes: remove AKEYREAD1 as XON return, - MOV #SLEEP,X ;2 and set XON return = SLEEP - .word 154Dh ;7 PUSHM IP,S,T,W,X before SLEEP (and so WAKE on any interrupts) -; --------------------------------------; - -; ======================================; -RXON: ; -; ======================================; - .IFDEF TERMINALXONXOFF ; - MOV #17,&TERMTXBUF ;4 move char XON into TX_buf - .ENDIF ; - .IFDEF TERMINALCTSRTS ; - BIC.B #RTS,&HANDSHAKOUT ;4 set RTS low - .ENDIF ; - .IFDEF TERMINALXONXOFF ; - .IF TERMINALBAUDRATE/FREQUENCY <230400 -RXON_LOOP BIT #UCTXIFG,&TERMIFG ;3 wait the sending end of XON, useless at high baudrates - JZ RXON_LOOP ;2 - .ENDIF ; - .ENDIF ; -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv; -; starts first and 3th stopwatches ; -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; - RET ;4 to BACKGND (End of file download or quiet input) or AKEYREAD1 (get next line of file downloading) -; --------------------------------------; ...or user defined - -; ASMWORD "RXON" -; JMP RXON - -; ASMWORD "RXOFF" -; ======================================; -RXOFF: ; NOP11 -; ======================================; - .IFDEF TERMINALXONXOFF ; - MOV #19,&TERMTXBUF ;4 move XOFF char into TX_buf - .ENDIF ; - .IFDEF TERMINALCTSRTS ; - BIS.B #RTS,&HANDSHAKOUT ;4 set RTS high - .ENDIF ; - .IFDEF TERMINALXONXOFF ; - .IF TERMINALBAUDRATE/FREQUENCY <230400 -RXOFF_LOOP BIT #UCTXIFG,&TERMIFG ;3 wait the sending end of XOFF, useless at high baudrates - JZ RXOFF_LOOP ;2 - .ENDIF ; - .ENDIF ; - RET ;4 to ENDACCEPT, ...or user defined -; --------------------------------------; - - -; --------------------------------------; - ASMWORD "SLEEP" ; may be redirected -SLEEP: ; - MOV #PARENSLEEP,PC ;3 -; --------------------------------------; - -; --------------------------------------; - ASMWORD "(SLEEP)" ; -PARENSLEEP: ; - BIS &LPM_MODE,SR ;3 enter in LPMx sleep mode with GIE=1 -; --------------------------------------; default FAST FORTH mode (for its input terminal use) : LPM0. - -;############################################################################################################### -;############################################################################################################### - -; ### # # ####### ####### ###### ###### # # ###### ####### ##### # # ####### ###### ####### -; # ## # # # # # # # # # # # # # # # # # # # # -; # # # # # # # # # # # # # # # # # # # # # # -; # # # # # ##### ###### ###### # # ###### # ##### ####### ##### ###### ##### -; # # # # # # # # # # # # # # # # # # # # # -; # # ## # # # # # # # # # # # # # # # # # # -; ### # # # ####### # # # # ##### # # ##### # # ####### # # ####### - -;############################################################################################################### -;############################################################################################################### - - -; here, Fast FORTH sleeps, waiting any interrupt. -; IP,S,T,W,X,Y registers (R13 to R8) are free for any interrupt routine... -; ...and so PSP and RSP stacks with their rules of use. -; remember: in any interrupt routine you must include : BIC #0x78,0(RSP) before RETI -; to force return to SLEEP. -; or (bad idea ? previous SR flags are lost) simply : ADD #2 RSP, then RET instead of RETI - - -; ======================================; - JMP SLEEP ;2 here is the return for any interrupts, else TERMINAL_INT :-) -; ======================================; - - -; **************************************; -TERMINAL_INT: ; <--- TEMR RX interrupt vector, delayed by the LPMx wake up time -; **************************************; if wake up time increases, max bauds rate decreases... -; (ACCEPT) part II under interrupt ; Org Ptr -- len' -; --------------------------------------; - ADD #4,RSP ;1 remove SR and PC from stack, SR flags are lost (unused by FORTH interpreter) - .word 173Ah ;6 POPM W=buffer_bound,T=0Dh,S=20h,IP=AYEMIT_RET -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv; -; starts the 2th stopwatch ; -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; -AKEYREAD MOV.B &TERMRXBUF,Y ;3 read character into Y, UCRXIFG is cleared -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv; -; stops the 3th stopwatch ; 3th bottleneck result : 17~ + LPMx wake_up time ( + 5~ XON loop if F/Bds<230400 ) -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; -AKEYREAD1 ; <--- XON RET address 2 ; first emergency: anticipate XOFF on CR as soon as possible - CMP.B T,Y ;1 char = CR ? - JZ RXOFF ;2 then RET to ENDACCEPT -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv;+ 4 to send RXOFF -; stops the first stopwatch ;= first bottleneck, best case result: 24~ + LPMx wake_up time.. -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; ...or 11~ in case of empty line - CMP.B S,Y ;1 printable char ? - JHS ASTORETEST ;2 yes - CMP.B #8,Y ; char = BS ? - JNE WAITaKEY ; case of other control chars -; --------------------------------------; -; start of backspace ; made only by an human -; --------------------------------------; - CMP @PSP,TOS ; Ptr = Org ? - JZ WAITaKEY ; yes: do nothing - SUB #1,TOS ; no : dec Ptr -; --------------------------------------; - .IFDEF BACKSPACE_ERASE - MOV #BS_NEXT,IP ; - JMP YEMIT ; send BS -BS_NEXT FORTHtoASM ; - MOV #32,Y ; send SPACE to rub previous char - ADD #8,IP ; (BS_NEXT+2) + 8 = FORTHtoASM @ ! - JMP YEMIT ; - FORTHtoASM ; - MOV.B #8,Y ; - MOV #AYEMIT_RET,IP ; - .ENDIF -; --------------------------------------; - JMP YEMIT ; send BS -; --------------------------------------; -; end of backspace ; -; --------------------------------------; -ASTORETEST CMP W,TOS ; 1 Bound is reached ? - JZ YEMIT ; 2 yes: send echo then loopback - MOV.B Y,0(TOS) ; 3 no: store char @ Ptr, send echo then loopback - ADD #1,TOS ; 1 increment Ptr -YEMIT: .word 4882h ; hi7/4~ lo:12/4~ send/send_not echo to terminal - .word TERMTXBUF ; 3 MOV Y,&TERMTXBUF - .IF TERMINALBAUDRATE/FREQUENCY <230400 -YEMIT1 BIT #UCTXIFG,&TERMIFG ; 3 wait the sending end of previous char, useless at high baudrates - JZ YEMIT1 ; 2 - .ENDIF - mNEXT ; 4 -; --------------------------------------; -AYEMIT_RET FORTHtoASM ; 0 YEMII NEXT address; NOP9 - SUB #2,IP ; 1 set YEMIT NEXT address to AYEMIT_RET -WAITaKEY BIT #UCRXIFG,&TERMIFG ; 3 new char in TERMRXBUF ? - JZ WAITaKEY ; 2 no - JNZ AKEYREAD ; 2 yes -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv; -; stops the 2th stopwatch ; best case result: 31~/28~ (with/without echo) ==> 322/357 kBds/MHz -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; - -; --------------------------------------; -ENDACCEPT ; <--- XOFF return address -; --------------------------------------; - MOV #LPM0+GIE,&LPM_MODE ; reset LPM_MODE to default mode LPM0 for next line of input stream -DROPEXIT -; .word 1734h ;6 we can also restore R7 to R4 - SUB @PSP+,TOS ; Org Ptr -- len' - MOV @RSP+,IP ; 2 and continue with INTERPRET with GIE=0. - ; So FORTH machine is protected against any interrupt... - mNEXT ; ...until next falling down to LPMx mode of (ACCEPT) part1, -; **************************************; i.e. when the FORTH interpreter has no more to do. - -; ------------------------------------------------------------------------------ -; TERMINAL I/O, output part -; ------------------------------------------------------------------------------ - - -;Z (EMIT) c -- output character (byte) to the terminal -; hardware or software control on TX flow seems not necessary with UARTtoUSB bridges because -; they stop TX when their RX buffer is full. So no problem when the terminal input is echoed to output. - FORTHWORD "(EMIT)" -PARENEMIT: MOV TOS,Y ; 1 - MOV @PSP+,TOS ; 2 - .IF TERMINALBAUDRATE/FREQUENCY >=230400 -YEMIT2 BIT #UCTXIFG,&TERMIFG ; 3 wait the sending end of previous char (usefull for low baudrates) - JZ YEMIT2 ; 2 - .ENDIF - JMP YEMIT ;9 12~ - - -;https://forth-standard.org/standard/core/EMIT -;C EMIT c -- output character to the output device ; deferred word - FORTHWORD "EMIT" -EMIT: MOV #PARENEMIT,PC ;3 15~ - - -;Z ECHO -- connect console output (default) - FORTHWORD "ECHO" -ECHO: MOV #4882h,&YEMIT ; 4882h = MOV Y,& - mNEXT - -;Z NOECHO -- disconnect console output - FORTHWORD "NOECHO" -NOECHO: MOV #NEXT,&YEMIT ; NEXT = 4030h = MOV @IP+,PC - mNEXT - -; (CR) -- send CR to the output terminal (via EMIT) - FORTHWORD "(CR)" -PARENCR: SUB #2,PSP - MOV TOS,0(PSP) - MOV #0Dh,TOS - JMP EMIT - -;https://forth-standard.org/standard/core/CR -;C CR -- send CR to the output device - FORTHWORD "CR" -CR: MOV #PARENCR,PC - - -;https://forth-standard.org/standard/core/SPACE -;C SPACE -- output a space - FORTHWORD "SPACE" -SPACE: SUB #2,PSP ;1 - MOV TOS,0(PSP) ;3 - MOV #20h,TOS ;2 - JMP EMIT ;17~ 23~ - -;https://forth-standard.org/standard/core/SPACES -;C SPACES n -- output n spaces - FORTHWORD "SPACES" -SPACES: CMP #0,TOS - JZ SPACESEND - PUSH IP - MOV #SPACESNEXT,IP - JMP SPACE ;25~ -SPACESNEXT FORTHtoASM - SUB #2,IP ;1 - SUB #1,TOS ;1 - JNZ SPACE ;25~ ==> 27~ by space ==> 2.963 MBds @ 8 MHz - MOV @RSP+,IP -SPACESEND MOV @PSP+,TOS - mNEXT - - -;https://forth-standard.org/standard/core/TYPE -;C TYPE adr len -- type line to terminal - FORTHWORD "TYPE" -TYPE: CMP #0,TOS - JZ TWODROP - MOV @PSP,W - ADD TOS,0(PSP) - MOV W,TOS - mDOCOL - .word xdo -TYPELOOP .word II,CFETCH,EMIT,xloop,TYPELOOP ; 13+6+15+16= 50~ char loop ==> 1.6MBds @ 8MHz - .word EXIT - + MOV #-1,Y + JMP DOTTODDOT ; ------------------------------------------------------------------------------ ; STRINGS PROCESSING ; ------------------------------------------------------------------------------ - -;Z (S") -- addr u run-time code for S" -; get address and length of string. -XSQUOTE: SUB #4,PSP ; 1 -- x x TOS ; push old TOS on stack - MOV TOS,2(PSP) ; 3 -- TOS x x ; and reserve one cell on stack - MOV.B @IP+,TOS ; 2 -- x u ; u = lenght of string - MOV IP,0(PSP) ; 3 -- addr u - ADD TOS,IP ; 1 -- addr u IP=addr+u=addr(end_of_string) - BIT #1,IP ; 1 -- addr u IP=addr+u Carry set/clear if odd/even - ADDC #0,IP ; 1 -- addr u IP=addr+u aligned - mNEXT ; 4 16~ - - .IFDEF LOWERCASE - - FORTHWORD "CAPS_ON" -CAPS_ON: MOV #-1,&CAPS ; state by default - mNEXT - - FORTHWORD "CAPS_OFF" -CAPS_OFF: MOV #0,&CAPS - mNEXT - -;https://forth-standard.org/standard/core/Sq -;C S" -- compile in-line string - FORTHWORDIMM "S\34" ; immediate -SQUOTE: mDOCOL - .word lit,XSQUOTE,COMMA -SQUOTE1 .word CAPS_OFF - .word lit,'"',WORDD ; -- c-addr (= HERE) - .word CAPS_ON - FORTHtoASM - MOV @RSP+,IP - MOV.B @TOS,TOS ; -- u - SUB #1,TOS ; -1 byte - ADD TOS,&DDP - MOV @PSP+,TOS -CELLPLUSALIGN - BIT #1,&DDP ;3 - ADDC #2,&DDP ;4 +2 bytes - mNEXT - - .ELSE - -;https://forth-standard.org/standard/core/Sq -;C S" -- compile in-line string - FORTHWORDIMM "S\34" ; immediate -SQUOTE: mDOCOL + FORTHWORDIMM "S\34" ; immediate +; https://forth-standard.org/standard/core/Sq +; S" -- compile in-line string +SQUOTE MOV #0,&CAPS ; CAPS OFF + mDOCOL .word lit,XSQUOTE,COMMA -SQUOTE1 .word lit,'"',WORDD ; -- c-addr (= HERE) - FORTHtoASM +SQUOTE1 .word lit,'"' ; separator for WORD + .word WORDD ; -- c-addr (= HERE) + .word $+2 + MOV #32,&CAPS ; CAPS ON + MOV.B @TOS,TOS ; -- u + ADD #1,TOS ; -- u+1 + BIT #1,TOS ;1 C = ~Z + ADDC TOS,&DDP +DROPEXIT MOV @PSP+,TOS MOV @RSP+,IP - MOV.B @TOS,TOS ; -- u - SUB #1,TOS ; -1 byte - ADD TOS,&DDP - MOV @PSP+,TOS -CELLPLUSALIGN - BIT #1,&DDP ;3 carry set if 1 - ADDC #2,&DDP ;4 +2 bytes - mNEXT - - .ENDIF ; LOWERCASE + MOV @IP+,PC -;https://forth-standard.org/standard/core/Dotq -;C ." -- compile string to print - FORTHWORDIMM ".\34" ; immediate -DOTQUOTE: mDOCOL + FORTHWORDIMM ".\34" ; immediate +; https://forth-standard.org/standard/core/Dotq +; ." -- compile string to print +DOTQUOTE mDOCOL .word SQUOTE .word lit,TYPE,COMMA,EXIT ;------------------------------------------------------------------------------- ; INTERPRETER ;------------------------------------------------------------------------------- - -;https://forth-standard.org/standard/core/WORD -;C WORD char -- addr Z=1 if len=0 -; parse a word delimited by char separator -; "word" is capitalized -; TOIN is the relative displacement into buffer -; spaces (as separator) filled line = 25 cycles + 7 cycles by char FORTHWORD "WORD" -WORDD: MOV #SOURCE_LEN,S ;2 -- separator - MOV @S+,X ;2 X = buf_len - MOV @S+,W ;2 W = buf_org - ADD W,X ;1 W = buf_org X = buf_org + buf_len = buf_end - ADD @S+,W ;2 W = buf_org + >IN = buf_ptr X = buf_end - MOV @S,Y ;2 -- separator W = buf_ptr X = buf_end Y = HERE, as dst_ptr -SKIPCHARLOO CMP W,X ;1 buf_ptr = buf_end ? - JZ EOL_END ;2 -- separator if yes : End Of Line ! - CMP.B @W+,TOS ;2 does char = separator ? - JZ SKIPCHARLOO ;2 -- separator if yes -SCANWORD SUB #1,W ;1 - MOV #96,T ;2 T = 96 = ascii(a)-1 (test value set in a register before SCANWORD loop) -SCANWORDLOO ; -- separator 15/23 cycles loop for upper/lower case char... write words in upper case ! - MOV.B S,0(Y) ;3 first time puts anything in dst word length, then put char @ dst. - CMP W,X ;1 buf_ptr = buf_end ? - JZ SCANWORDEND ;2 if yes - MOV.B @W+,S ;2 - CMP.B S,TOS ;1 does char = separator ? - JZ SCANWORDEND ;2 if yes - ADD #1,Y ;1 increment dst just before test loop - CMP.B S,T ;1 char U< 'a' ? ('a'-1 U>= char) this condition is tested at each loop - JC SCANWORDLOO ;2 15~ upper case char loop - .IFDEF LOWERCASE ; -QCAPS CMP #0,&CAPS ;3 CAPS is OFF ? (case available only for ABORT" ." .( ) - JZ SCANWORDLOO ;2 yes - .ENDIF ; LOWERCASE ; here CAPS is ON (other cases) - CMP.B #123,S ;2 char U>= 'z'+1 ? - JC SCANWORDLOO ;2 if yes - SUB.B #32,S ;2 convert lowercase char to uppercase - JMP SCANWORDLOO ;2 - -SCANWORDEND SUB &SOURCE_ADR,W ;3 -- separator W=buf_ptr - buf_org = new >IN (first char separator next) - MOV W,&TOIN ;3 update >IN -EOL_END MOV &DDP,TOS ;3 -- c-addr - SUB TOS,Y ;1 Y=Word_Length - MOV.B Y,0(TOS) ;3 - mNEXT ;4 -- c-addr 40 words Z=1 <==> lenght=0 <==> EOL - - -;https://forth-standard.org/standard/core/FIND -;C FIND c-addr -- c-addr 0 if not found ; flag Z=1 -;C xt -1 if found ; flag Z=0 -;C xt 1 if immediate ; flag Z=0 +; https://forth-standard.org/standard/core/WORD +; WORD char -- addr Z=1 if len=0 +; parse a word delimited by char separator; by default (CAPS=$20), this word is capitalized. +; if first char is TICK, the entire word is not capitalized. +WORDD MOV #SOURCE_LEN,S ;2 -- separator + MOV @S+,X ;2 X = src_len + MOV @S+,W ;2 W = src_org + ADD W,X ;1 X = src_end + ADD @S+,W ;2 W = src_org + >IN = src_ptr + MOV @S,Y ;2 Y = HERE = dst_ptr +SKIPCHARLOO CMP W,X ;1 src_ptr = src_end ? + JZ SKIPCHAREND ;2 if yes : End Of Line ! + CMP.B @W+,TOS ;2 does char = separator ? + JZ SKIPCHARLOO ;2 if yes; 7~ loop + SUB #1,W ;1 move back one the (post incremented) pointer +SCANWORD MOV #96,T ;2 T = 96 = ascii(a)-1 (test value set in a register before SCANWORD loop) + MOV &CAPS,rDODOES ;3 CAPS OFF = 0, CAPS ON = $20. +QSCANTICK CMP.B #27h,0(W) ;4 first char = TICK ? + JNZ SCANWORDLOO ;2 no + MOV #0,rDODOES ;1 yes, don't change to upper case +SCANWORDLOO MOV.B S,0(Y) ;3 first time make room in dst for word length; next, put char @ dst. + CMP W,X ;1 src_ptr = src_end ? + JZ SCANWORDEND ;2 if yes + MOV.B @W+,S ;2 + CMP.B S,TOS ;1 does char = separator ? + JZ SCANWORDEND ;2 if yes + ADD #1,Y ;1 increment dst just before test loop + CMP.B S,T ;1 char U< 'a' ? ('a'-1 U>= char) this condition is tested at each loop + JC SCANWORDLOO ;2 15~ upper case char loop + CMP.B #123,S ;2 char U>= 'z'+1 ? + JC SCANWORDLOO ;2 loopback if yes + SUB.B rDODOES,S ;1 convert a...z to A...Z if CAPS ON (rDODOES=$20) + JMP SCANWORDLOO ;2 22~ lower case char loop +SCANWORDEND MOV #XDODOES,rDODOES ;2 +SKIPCHAREND SUB &SOURCE_ORG,W ;3 -- separator W=src_ptr - src_org = new >IN (first char separator next) + MOV W,&TOIN ;3 update >IN + MOV &DDP,TOS ;3 -- c-addr + SUB TOS,Y ;1 Y=Word_Length + MOV.B Y,0(TOS) ;3 + MOV @IP+,PC ;4 -- c-addr 48 words Z=1 <==> lenght=0 <==> EOL, Z is tested by INTERPRET + + FORTHWORD "FIND" ; +; https://forth-standard.org/standard/core/FIND +; FIND c-addr -- c-addr 0 if not found ; flag Z=1 c-addr at transient RAM area (HERE) +; CFA -1 if found ; flag Z=0 +; CFA 1 if immediate ; flag Z=0 ; compare WORD at c-addr (HERE) with each of words in each of listed vocabularies in CONTEXT ; FIND to WORDLOOP : 14/20 cycles, -; mismatch word loop: 13 cycles on len, +8 cycles on first char, +; mismatch word loop: 13 cycles on len, +7 cycles on first char, ; +10 cycles char loop, ; VOCLOOP : 12/18 cycles, ; WORDFOUND to end : 21 cycles. -; note: with 16 threads vocabularies, FIND takes about 75% of CORETEST.4th processing time - - FORTHWORD "FIND" -FIND: SUB #2,PSP ;1 -- ???? c-addr reserve one cell here, not at FINDEND because interacts with flag Z - MOV TOS,S ;1 S=c-addr - MOV.B @S,rDOCON ;2 R5= string count - MOV.B #80h,rDODOES ;2 R4= immediate mask - MOV #CONTEXT,T ;2 -VOCLOOP MOV @T+,TOS ;2 -- ???? VOC_PFA T=CTXT+2 - CMP #0,TOS ;1 no more vocabulary in CONTEXT ? - JZ FINDEND ;2 -- ???? 0 yes ==> exit; Z=1 +; note: with 16 threads vocabularies, FIND takes only! 75% of CORETEST.4th processing time +FIND SUB #2,PSP ;1 -- ???? c-addr reserve one cell, not at FINDEND because kill flag Z + MOV TOS,S ;1 S=c-addr + MOV.B @S,rDOCON ;2 rDOCON= string count + MOV.B #80h,rDODOES ;2 rDODOES= immediate mask + MOV #CONTEXT,T ;2 +VOCLOOP MOV @T+,TOS ;2 -- ???? VOC_PFA T=CTXT+2 + CMP #0,TOS ;1 no more vocabulary in CONTEXT ? + JZ FINDEND ;2 -- ???? 0 yes ==> exit; Z=1 .SWITCH THREADS .CASE 1 .ELSECASE ; search thread add 6cycles 5words -MAKETHREAD MOV.B 1(S),Y ;3 -- ???? VOC_PFA0 S=c-addr Y=CHAR0 + MOV.B 1(S),Y ;3 -- ???? VOC_PFA0 S=c-addr Y=first char of c-addr string AND.B #(THREADS-1)*2,Y ;2 -- ???? VOC_PFA0 Y=thread offset - ADD Y,TOS ;1 -- ???? VOC_PFAx + ADD Y,TOS ;1 -- ???? VOC_PFAx TOS = words set entry .ENDCASE - ADD #2,TOS ;1 -- ???? VOC_PFA+2 -WORDLOOP MOV -2(TOS),TOS ;3 -- ???? [VOC_PFA] [VOC_PFA] first, then [LFA] - CMP #0,TOS ;1 -- ???? NFA no more word in the thread ? - JZ VOCLOOP ;2 -- ???? NFA yes ==> search next voc in context - MOV TOS,X ;1 - MOV.B @X+,Y ;2 TOS=NFA,X=NFA+1,Y=NFA_char - BIC.B rDODOES,Y ;1 hide Immediate bit -LENCOMP CMP.B rDOCON,Y ;1 compare lenght - JNZ WORDLOOP ;2 -- ???? NFA 13~ word loop on lenght mismatch - MOV S,W ;1 W=c-addr -CHARLOOP ADD #1,W ;1 -CHARCOMP CMP.B @X+,0(W) ;4 compare chars - JNZ WORDLOOP ;2 -- ???? NFA 21~ word loop on first char mismatch - SUB.B #1,Y ;1 decr count - JNZ CHARLOOP ;2 -- ???? NFA 10~ char loop -WORDFOUND BIT #1,X ;1 - ADDC #0,X ;1 - MOV X,S ;1 S=aligned CFA - MOV.B @TOS,W ;2 -- ???? NFA W=NFA_first_char - MOV #1,TOS ;1 -- ???? 1 preset immediate flag - CMP.B #0,W ;1 W is negative if immediate flag - JN FINDEND ;2 -- ???? 1 - SUB #2,TOS ;1 -- ???? -1 -FINDEND MOV S,0(PSP) ;3 not found: -- c-addr 0 flag Z=1 - ; found: -- xt -1|+1 (not immediate|immediate) flag Z=0 - MOV #xdocon,rDOCON ;2 - MOV #xdodoes,rDODOES;2 - mNEXT ;4 42/47 words - - -THREEDROP ADD #2,PSP -TWODROP ADD #2,PSP - MOV @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/toNUMBER -;C convert a string to double number until count2 = 0 or until not convertible char -;C >NUMBER ud1lo|ud1hi addr1 count1 -- ud2lo|ud2hi addr2 count2 - - .IFDEF MPY - - FORTHWORD ">NUMBER" ; 23 cycles + 32/34 cycles DEC/HEX char loop -TONUMBER: MOV @PSP+,S ;2 S = adr - MOV @PSP+,Y ;2 Y = ud1hi - MOV @PSP,X ;2 X = ud1lo - SUB #4,PSP ;1 - MOV &BASE,T ;3 -TONUMLOOP MOV.B @S,W ;2 -- ud1lo ud1hi adr count W=char -DDIGITQ SUB.B #30h,W ;2 skip all chars < '0' - CMP.B #10,W ;2 char was > "9" ? - JLO DDIGITQNEXT ;2 no - SUB.B #7,W ;2 skip all chars between "9" and "A" -DDIGITQNEXT CMP T,W ;1 digit-base - JHS TONUMEND ;2 -- ud1lo ud1hi adr count abort - MOV X,&MPY32L ;3 Load 1st operand (ud1lo) - MOV Y,&MPY32H ;3 Load 1st operand (ud1hi) - MOV T,&OP2 ;3 Load 2nd operand with BASE - MOV &RES0,X ;3 lo result in X (ud2lo) - MOV &RES1,Y ;3 hi result in Y (ud2hi) - ADD W,X ;1 ud2lo + digit - ADDC #0,Y ;1 ud2hi + carry - ADD #1,S ;1 -- ud1lo ud1hi adr count S=adr+1 - SUB #1,TOS ;1 -- ud1lo ud1hi adr count-1 - JNZ TONUMLOOP ;2 if count <>0 - MOV X,4(PSP) ;3 -- ud2lo ud1hi adr count2 - MOV Y,2(PSP) ;3 -- ud2lo ud2hi adr count2 -TONUMEND MOV S,0(PSP) ;3 -- ud2lo ud2hi addr2 count2 - mNEXT ;4 38 words - - -; convert a string to a signed number; FORTH 2012 prefixes $, %, # are recognized -; 32 bits numbers (with decimal point) are recognized -;Z ?NUMBER c-addr -- n -1 if convert ok ; flag Z=0 -;Z c-addr -- c-addr 0 if convert ko ; flag Z=1 - -; FORTHWORD "?NUMBER" -QNUMBER: PUSH #0 ;3 -- c-addr - PUSH IP ;3 - MOV &BASE,T ;3 T=BASE - PUSH T ;3 R-- sign IP base -; ----------------------------------; -; decimal point process add-on ; -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv; - BIC #UF9,SR ;2 reset flag UF9 used here as Decimal Point flag - MOV.B @TOS,IP ;2 IP = count of chars - ADD TOS,IP ;1 IP = end address - MOV TOS,S ;1 S = ptr - MOV.B #'.',W ;2 W = '.' = Decimal Point DP -SearchDP CMP S,IP ;1 IP U< S ? - JLO SearchDPEND ;2 - CMP.B @S+,W ;2 DP found ? - JNE SearchDP ;2 7~ loop by char -DPfound BIS #UF9,SR ;2 DP found: set flag UF9 -DPrubLoop MOV.B @S+,-2(S) ;4 rub out decimal point - CMP S,IP ;1 and move left one all susbsequent chars - JHS DPrubLoop ;2 7~ loop by char - SUB.B #1,0(TOS) ;3 and decrement count of chars -SearchDPEND ; -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; - MOV #0,X ;1 X=ud1lo - MOV #0,Y ;1 Y=ud1hi - MOV #QNUMNEXT,IP ;2 return from >NUMBER - SUB #8,PSP ;1 -- x x x x c-addr - MOV TOS,6(PSP) ;3 -- c-addr x x x c-addr - MOV TOS,S ;1 S=addrr - MOV.B @S+,TOS ;2 -- c-addr x x x cnt - MOV.B @S,W ;2 W=char - CMP.B #'-',W ;2 - JHS QSIGN ;2 speed up for not prefixed numbers -QHEXA MOV #16,T ;2 BASE = 16 - SUB.B #'$',W ;2 = 0 ==> "$" : hex number ? - JZ PREFIXED ;2 -QBINARY MOV #2,T ;1 BASE = 2 - SUB.B #1,W ;1 "%" - "$" - 1 = 0 ==> '%' : bin number ? - JZ PREFIXED ;2 -QDECIMAL ADD #8,T ;1 BASE = 10 - ADD.B #2,W ;1 "#" - "%" + 2 = 0 ==> '#' : decimal number ? - JNZ TONUMLOOP ;2 if no the conversion return will be ko -PREFIXED ADD #1,S ;1 addr+1 to skip prefix - SUB #1,TOS ;1 -- c-addr x x x cnt-1 - MOV.B @S,W ;2 W=2th char, S=adr - CMP.B #'-',W ;2 -QSIGN JNZ TONUMLOOP ;15 + 32/34 cycles DEC/HEX char loop -QSIGNYES ADD #1,S ;1 addr+1 to skip "-" - SUB #1,TOS ;1 -- c-addr x x x cnt-1 - MOV #-1,4(RSP) ;3 R-- sign IP BASE - JMP TONUMLOOP ;15 + 32/34 cycles DEC/HEX char loop + ADD #2,TOS ;1 -- ???? VOC_PFA+2 +WORDLOOP MOV -2(TOS),TOS ;3 -- ???? NFA [VOC_PFA] first, then [LFA] + CMP #0,TOS ;1 -- ???? NFA no more word in the thread ? + JZ VOCLOOP ;2 -- ???? NFA yes ==> search next voc in context + MOV TOS,X ;1 + MOV.B @X+,Y ;2 TOS=NFA,X=NFA+1,Y=NFA_char + BIC.B rDODOES,Y ;1 hide Immediate bit +LENCOMP CMP.B rDOCON,Y ;1 compare lenght + JNZ WORDLOOP ;2 -- ???? NFA 13~ word loop on lenght mismatch + MOV S,W ;1 W=c-addr +CHARCOMP CMP.B @X+,1(W) ;4 compare chars + JNZ WORDLOOP ;2 -- ???? NFA 20~ word loop on first char mismatch + ADD #1,W ;1 + SUB.B #1,Y ;1 decr count + JNZ CHARCOMP ;2 -- ???? NFA 10~ char loop + +WORDFOUND BIT #1,X ;1 + ADDC #0,X ;1 + MOV X,S ;1 S=aligned CFA + CMP.B #0,0(TOS) ;3 -- ???? NFA 0(TOS)=NFA_first_char + MOV #1,TOS ;1 -- ???? 1 preset immediate flag + JN FINDEND ;2 -- ???? 1 jump if negative: NFA have immediate bit set + SUB #2,TOS ;1 -- ???? -1 +FINDEND MOV S,0(PSP) ;3 not found: -- c-addr 0 flag Z=1 + MOV #xdocon,rDOCON ;2 found: -- xt -1|+1 (not immediate|immediate) flag Z=0 + MOV #xdodoes,rDODOES ;2 + MOV @IP+,PC ;4 42/47 words + + .IFDEF MPY_32 ; if 32 bits hardware multiplier + + FORTHWORD ">NUMBER" +; >NUMBER ud1lo ud1hi addr1 cnt1 -- ud2lo ud2hi addr2 cnt2 +; https://forth-standard.org/standard/core/toNUMBER +; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits, +; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE. +; Conversion continues left-to-right until a character that is not convertible (including '.' ',' '_') +; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character +; or the first character past the end of the string if the string was entirely converted. +; u2 is the number of unconverted characters in the string. +; An ambiguous condition exists if ud2 overflows during the conversion. +TONUMBER MOV @PSP+,S ;2 -- ud1lo ud1hi cnt1 S = addr1 + MOV @PSP+,Y ;2 -- ud1lo cnt1 Y = ud1hi + MOV @PSP,X ;2 -- x cnt1 X = ud1lo + SUB #4,PSP ;1 -- x x x cnt + MOV &BASE,T ;3 +TONUMLOOP MOV.B @S,W ;2 -- x x x cnt S=adr, T=base, W=char, X=udlo, Y=udhi +DDIGITQ SUB.B #30h,W ;2 skip all chars < '0' + CMP.B #10,W ;2 char was U< 58 (U< ':') ? + JNC DDIGITQNEXT ;2 no + SUB.B #7,W ;2 + CMP.B #10,W ;2 + JNC TONUMEND ;2 -- x x x cnt if '9' < char < 'A', then return to QNUMBER with Z=0 +DDIGITQNEXT CMP T,W ;1 digit-base + BIC #Z,SR ;1 reset Z before return to QNUMBER because + JC TONUMEND ;2 with Z=1, QNUMBER conversion would be true :-( +UDSTAR MOV X,&MPY32L ;3 Load 1st operand (ud1lo) + MOV Y,&MPY32H ;3 Load 1st operand (ud1hi) + MOV T,&OP2 ;3 Load 2nd operand with BASE + MOV &RES0,X ;3 lo result in X (ud2lo) + MOV &RES1,Y ;3 hi result in Y (ud2hi) +MPLUS ADD W,X ;1 ud2lo + digit + ADDC #0,Y ;1 ud2hi + carry +TONUMPLUS ADD #1,S ;1 adr+1 + SUB #1,TOS ;1 -- x x x cnt cnt-1 + JNZ TONUMLOOP ;2 if count <>0 +TONUMEND MOV S,0(PSP) ;3 -- x x addr2 cnt2 + MOV Y,2(PSP) ;3 -- x ud2hi addr2 cnt2 + MOV X,4(PSP) ;3 -- ud2lo ud2hi addr2 cnt2 + MOV @IP+,PC ;4 42 words + +; ?NUMBER makes the interface between INTERPRET and >NUMBER; it's a subset of INTERPRET. +; convert a string to a signed number; FORTH 2012 prefixes $ % # are recognized, +; FORTH 2012 'char' numbers also, digits separator '_' also. +; with DOUBLE_INPUT switched ON, 32 bits signed numbers (with decimal point) are recognized, +; with FIXPOINT_INPUT switched ON, Q15.16 signed numbers (with comma) are recognized. +; prefixes ' # % $ - are processed before calling >NUMBER +; chars . , _ are processed as >NUMBER exits. +;Z ?NUMBER addr -- n|d -1 if convert ok ; flag Z=0, UF9=1 if double +;Z addr -- addr 0 if convert ko ; flag Z=1 +QNUMBER + .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT + BIC #UF9,SR ;2 reset UF9 used as double number flag + .ENDIF ; + MOV &BASE,T ;3 T=BASE + MOV #0,S ;1 S=sign of result + PUSHM #3,IP ;5 R-- IP sign base PUSH IP,S,T + MOV #TONUMEXIT,IP ;2 set TONUMEXIT as return from >NUMBER + MOV #0,X ;1 X=ud1lo + MOV #0,Y ;1 Y=ud1hi + SUB #8,PSP ;1 -- x x x x addr make room for TOS and >NUMBER + MOV TOS,6(PSP) ;3 -- addr x x x addr + MOV TOS,S ;1 S=addr + MOV.B @S+,TOS ;2 -- addr x x x cnt TOS=count +QTICK CMP.B #027h,0(S) ;4 prefix = ' ? + JNZ QNUMLDCHAR ;2 no + MOV.B 1(S),S ;3 + MOV S,4(PSP) ;3 -- addr ud2lo x x cnt ud2lo = ASCII code of 'char' + CMP.B #3,TOS ;2 string must be 3 chars long + JMP QNUMNEXT ;2 +QNUMLDCHAR MOV.B @S,W ;2 W=char +QMINUS SUB.B #'-',W ;2 sign minus ? + JNC QBINARY ;2 jump if char < '-' + JNZ TONUMLOOP ;2 -- addr x x x cnt jump if char > '-' + MOV #-1,2(RSP) ;3 R-- IP sign base set sign flag + JMP PREFIXED ;2 +QBINARY MOV #2,T ;1 preset base 2 + ADD.B #8,W ;1 binary '%' prefix ? + JZ PREFIXED ;2 yes +QDECIMAL ADD #8,T ;1 preset base 10 + ADD.B #2,W ;1 decimal '#' prefix ? + JZ PREFIXED ;2 yes +QHEXA MOV #16,T ;2 preset base 16 + ADD.B #-1,W ;1 hex '$' prefix ? + JNZ QNUMNEXT ;2 -- addr x x x cnt abort if not recognized prefix +PREFIXED ADD #1,S ;1 + SUB #1,TOS ;1 -- addr x x x cnt-1 S=adr+1 TOS=count-1 + JMP QNUMLDCHAR ;2 ; ----------------------------------; +TONUMEXIT .word $+2 ; -- addr ud2lo-hi addr2 cnt2 R-- IP sign BASE S=addr2 +; ----------------------------------; + JZ QNUMNEXT ;2 TOS=cnt2, Z=1 if conversion is ok +; ----------------------------------; + SUB #2,IP ; redefines TONUMEXIT as >NUMBER return, if loopback applicable + CMP.B #28h,W ; rejected char by >NUMBER is a underscore ? ('_'-30h-7 = 28h) + JZ TONUMPLUS ; yes: loopback to >NUMBER to skip char +; ----------------------------------; + .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT + BIT #UF9,SR ; UF9 already set ? ( when you have typed .. ) + JNZ QNUMNEXT ; yes, goto QNUMKO + BIS #UF9,SR ;2 set double number flag + .ENDIF +; ----------------------------------; + .IFDEF DOUBLE_INPUT ; + CMP.B #0F7h,W ;2 rejected char by >NUMBER is a decimal point ? ('.'-37h = -9) + JZ TONUMPLUS ;2 yes, loopback to >NUMBER to skip char + .ENDIF ; ; ----------------------------------; -QNUMNEXT FORTHtoASM ; -- c-addr ud2lo ud2hi addr2 count2 - ADD #2,PSP ;1 - CMP #0,TOS ;1 -- c-addr ud2lo ud2hi cnt2 n=0 ? conversion is ok ? - .word 0172Ch ;4 -- c-addr ud2lo ud2hi sign POPM S,IP,TOS; TOS = sign flag = {-1;0} - MOV S,&BASE ;3 - JZ QNUMOK ;2 -- c-addr ud2lo ud2hi sign conversion OK -QNUMKO ADD #4,PSP ;1 -- c-addr sign - AND #0,TOS ;1 -- c-addr ff TOS=0 and Z=1 ==> conversion ko - mNEXT ;4 69 + .IFDEF FIXPOINT_INPUT ; + CMP.B #0F5h,W ;2 rejected char by >NUMBER is a comma ? (','-37h = -0Bh) + JNZ QNUMNEXT ;2 no: with Z=0 ==> goto QNUMKO ; ----------------------------------; -QNUMOK MOV 2(PSP),4(PSP) ; -- udlo udlo udhi sign - MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back !!! - XOR #-1,TOS ;1 -- udlo udhi inv(sign) - JNZ QDOUBLE ;2 if jump : TOS=-1 and Z=0 ==> conversion ok -Q2NEGATE XOR #-1,TOS ;1 -- udlo udhi tf - XOR #-1,2(PSP) ;3 -- dlo-1 dhi-1 tf - XOR #-1,0(PSP) ;3 -- dlo-1 udhi tf - ADD #1,2(PSP) ;3 -- dlo dhi-1 tf - ADDC #0,0(PSP) ;3 -- dlo dhi tf -QDOUBLE BIT #UF9,SR ;2 decimal point added ? - JNZ QNUMEND ;2 leave double - ADD #2,PSP ;1 leave number -QNUMEND mNEXT ;4 90 words TOS=-1 and Z=0 ==> conversion ok +S15Q16 MOV TOS,W ;1 -- addr ud2lo x x x W=cnt2 + MOV #0,X ;1 -- addr ud2lo x 0 x init X = ud2lo' = 0 +S15Q16LOOP MOV X,2(PSP) ;3 -- addr ud2lo ud2lo' ud2lo' x 0(PSP) = ud2lo' + SUB.B #1,W ;1 decrement cnt2 + MOV W,X ;1 X = cnt2-1 + ADD S,X ;1 X = end_of_string-1,-2,-3... + MOV.B @X,X ;2 X = last char of string first (reverse conversion) + SUB.B #30h,X ;2 char --> digit conversion + CMP.B #10,X ;2 + JNC QS15Q16DIGI ;2 if 0 <= digit < 10 + SUB.B #7,X ;2 char + CMP.B #10,X ;2 to skip all chars between "9" and "A" + JNC S15Q16EOC ;2 +QS15Q16DIGI CMP T,X ;1 R-- IP sign BASE is X a digit ? + JC S15Q16EOC ;2 -- addr ud2lo ud2lo' x ud2lo' if X>=base + MOV X,0(PSP) ;3 -- addr ud2lo ud2lo' digit x + MOV T,TOS ;1 -- addr ud2lo ud2lo' digit base R-- IP sign base + PUSHM #3,S ;5 PUSH S,T,W: R-- IP sign base addr2 base cnt2 + CALL #MUSMOD ;4 -- addr ud2lo ur uqlo uqhi CALL MU/MOD + POPM #3,S ;5 restore W,T,S: R-- IP sign BASE + JMP S15Q16LOOP ;2 W=cnt +S15Q16EOC MOV 4(PSP),2(PSP) ;5 -- addr ud2lo ud2hi uqlo x ud2lo from >NUMBER becomes here ud2hi part of Q15.16 + MOV @PSP,4(PSP) ;4 -- addr ud2lo ud2hi x x uqlo becomes ud2lo part of Q15.16 + CMP.B #0,W ;1 count = 0 if end of conversion ok + .ENDIF ; FIXPOINT_INPUT ; ; ----------------------------------; +QNUMNEXT POPM #3,IP ;5 -- addr ud2lo-hi x x POPM T,S,IP S = sign flag = {-1;0} + MOV S,TOS ;1 -- addr ud2lo-hi x sign + MOV T,&BASE ;3 + JZ QNUMOK ;2 -- addr ud2lo-hi x sign conversion OK if Z=1 +QNUMKO + .IFDEF DOUBLE_NUMBERS ; + BIC #UF9,SR ;2 reset flag UF9, before next use as double number flag + .ENDIF + ADD #6,PSP ;1 -- addr sign + AND #0,TOS ;1 -- addr ff TOS=0 and Z=1 ==> conversion ko + MOV @IP+,PC ;4 +; ----------------------------------; + .IFDEF DOUBLE_NUMBERS ; -- addr ud2lo-hi x sign +QNUMOK ADD #2,PSP ;1 -- addr ud2lo-hi sign + MOV 2(PSP),4(PSP) ;5 -- udlo udlo udhi sign + MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back. + XOR #-1,TOS ;1 -- udlo udhi inv(sign) + JNZ QDOUBLE ;2 if jump : TOS=-1 and Z=0 ==> conversion ok + XOR #-1,TOS ;1 -- udlo udhi tf +QDNEGATE XOR #-1,2(PSP) ;3 + XOR #-1,0(PSP) ;3 -- (dlo dhi)-1 tf + ADD #1,2(PSP) ;3 + ADDC #0,0(PSP) ;3 +QDOUBLE BIT #UF9,SR ;2 -- dlo dhi tf decimal point or comma fixpoint ? + JNZ QNUMEND ;2 leave double + ADD #2,PSP ;1 -- n tf leave number +QNUMEND MOV @IP+,PC ;4 TOS<>0 and Z=0 ==> conversion ok + .ELSE +QNUMOK ADD #4,PSP ;1 -- addr ud2lo sign + MOV @PSP+,0(PSP) ;4 -- udlo sign note : PSP is incremented before write back !!! + XOR #-1,TOS ;1 -- udlo inv(sign) + JNZ QNUMEND ;2 if jump : TOS=-1 and Z=0 ==> conversion ok + XOR #-1,TOS ;1 -- udlo tf TOS=-1 and Z=0 +QNEGATE XOR #-1,0(PSP) ;3 + ADD #1,0(PSP) ;3 -- n tf +QNUMEND MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok + .ENDIF ; DOUBLE_NUMBERS ; .ELSE ; no hardware MPY + FORTHWORD "UM*" +; T.I. UNSIGNED MULTIPLY SUBROUTINE: U1 x U2 -> Ud +; https://forth-standard.org/standard/core/UMTimes +; UM* u1 u2 -- ud unsigned 16x16->32 mult. +UMSTAR MOV @PSP,S ;2 MDlo +UMSTAR1 MOV #0,T ;1 MDhi=0 + MOV #0,X ;1 RES0=0 + MOV #0,Y ;1 RES1=0 + MOV #1,W ;1 BIT TEST REGISTER +UMSTARLOOP BIT W,TOS ;1 TEST ACTUAL BIT MRlo + JZ UMSTARNEXT ;2 IF 0: DO NOTHING + ADD S,X ;1 IF 1: ADD MDlo TO RES0 + ADDC T,Y ;1 ADDC MDhi TO RES1 +UMSTARNEXT ADD S,S ;1 (RLA LSBs) MDlo x 2 + ADDC T,T ;1 (RLC MSBs) MDhi x 2 + ADD W,W ;1 (RLA) NEXT BIT TO TEST + JNC UMSTARLOOP ;2 IF BIT IN CARRY: FINISHED 10~ loop + MOV X,0(PSP) ;3 low result on stack + MOV Y,TOS ;1 high result in TOS + MOV @IP+,PC ;4 17 words + FORTHWORD ">NUMBER" -TONUMBER: MOV @PSP,S ; -- ud1lo ud1hi adr count - MOV.B @S,S ; -- ud1lo ud1hi adr count S=char -DDIGITQ SUB.B #30h,S ;2 skip all chars < '0' - CMP.B #10,S ; char was > "9" ? - JLO DDIGITQNEXT ; -- ud1lo ud1hi adr count no - SUB.B #07h,S ; S=digit -DDIGITQNEXT CMP &BASE,S ; -- ud1lo ud1hi adr count digit-base - JHS TONUMEND ; U>= -UDSTAR .word 152Eh ; -- ud1lo ud1hi adr count PUSHM TOS,IP,S (2+1 push,TOS=Eh) - SUB #2,PSP ; -- ud1lo ud1hi adr x count - MOV 4(PSP),0(PSP) ; -- ud1lo ud1hi adr ud1hi count - MOV &BASE,TOS ; -- ud1lo ud1hi adr ud1hi u2=base - MOV #UMSTARNEXT1,IP ; -UMSTAR1 MOV #UMSTAR,PC ; ud1hi * base ; UMSTAR use S,T,W,X,Y -UMSTARNEXT1 FORTHtoASM ; -- ud1lo ud1hi adr ud3lo ud3hi - PUSH @PSP ; r-- count ud3lo - MOV 6(PSP),0(PSP) ; -- ud1lo ud1hi adr ud1lo ud3hi - MOV &BASE,TOS ; -- ud1lo ud1hi adr ud1lo u=base - MOV #UMSTARNEXT2,IP -UMSTAR2 MOV #UMSTAR,PC ; ud1lo * base ; UMSTAR use S,T,W,X,Y, and S is free for use -UMSTARNEXT2 FORTHtoASM ; -- ud1lo ud1hi adr ud2lo ud2hi r-- count IP digit ud3lo - ADD @RSP+,TOS ; -- ud1lo ud1hi adr ud2lo ud2hi r-- count IP digit add ud3lo to ud2hi -MPLUS ADD @RSP+,0(PSP) ; -- ud1lo ud1hi adr ud2lo ud2hi Ud2lo + digit - ADDC #0,TOS ; -- ud1lo ud1hi adr ud2lo ud2hi ud2hi + carry - MOV @PSP,6(PSP) ; -- ud2lo ud1hi adr ud2lo ud2hi - MOV TOS,4(PSP) ; -- ud2lo ud2hi adr ud2lo ud2hi - .word 171Dh ; -- ud2lo ud2hi adr ud2lo count POPM IP,TOS (1+1 pop,IP=D) - ADD #2,PSP ; -- ud2lo ud2hi adr count - ADD #1,0(PSP) ; -- ud2lo ud2hi adr+1 count - SUB #1,TOS ; -- ud2lo ud2hi adr+1 count-1 - JNZ TONUMBER -TONUMEND mNEXT ; 52 words - - -; convert a string to a signed number -;Z ?NUMBER c-addr -- n -1 if convert ok ; flag Z=0 -;Z c-addr -- c-addr 0 if convert ko ; flag Z=1 -; FORTH 2012 prefixes $, %, # are recognized -; FORTHWORD "?NUMBER" -QNUMBER: PUSH #0 ;3 -- c-addr - PUSH IP ;3 - PUSH &BASE ;3 R-- sign IP base +; https://forth-standard.org/standard/core/toNUMBER +; ud2 is the unsigned result of converting the characters within the string specified by c-addr1 u1 into digits, +; using the number in BASE, and adding each into ud1 after multiplying ud1 by the number in BASE. +; Conversion continues left-to-right until a character that is not convertible, including '.', ',' or '_', +; is encountered or the string is entirely converted. c-addr2 is the location of the first unconverted character +; or the first character past the end of the string if the string was entirely converted. +; u2 is the number of unconverted characters in the string. +; An ambiguous condition exists if ud2 overflows during the conversion. +; >NUMBER ud1lo|ud1hi addr1 count1 -- ud2lo|ud2hi addr2 count2 +TONUMBER MOV @PSP,S ;2 S=adr + MOV TOS,T ;1 T=count + MOV &BASE,W ;3 +TONUMLOOP MOV.B @S,Y ;2 -- ud1lo ud1hi x x S=adr, T=count, W=BASE, Y=char +DDIGITQ SUB.B #30h,Y ;2 skip all chars < '0' + CMP.B #10,Y ;2 char was > "9" ? + JNC DDIGITQNEXT ;2 -- ud1lo ud1hi x x no: good end + SUB.B #07,Y ;2 skip all chars between "9" and "A" + CMP.B #10,Y ;2 char was < "A" ? + JNC TONUMEND ;2 yes: for bad end +DDIGITQNEXT CMP W,Y ;1 -- ud1lo ud1hi x x digit-base + BIC #Z,SR ;1 reset Z before jmp TONUMEND because... + JC TONUMEND ;2 ...QNUMBER conversion will be true if Z = 1 :-( +UDSTAR PUSHM #6,IP ;8 -- ud1lo ud1hi x x save IP S T W X Y used by UM* r-- IP adr count base x digit + MOV 2(PSP),S ;3 -- ud1lo ud1hi x x S=ud1hi + MOV W,TOS ;1 -- ud1lo ud1hi x base + MOV #UMSTARNEXT1,IP ;2 +UMSTARONE JMP UMSTAR1 ;2 ud1hi * base -- x ud3hi X=ud3lo +UMSTARNEXT1 .word $+2 ; -- ud1lo ud1hi x ud3hi + MOV X,2(RSP) ;3 r-- IP adr count base ud3lo digit + MOV 4(PSP),S ;3 -- ud1lo ud1hi x ud3hi S=ud1lo + MOV 4(RSP),TOS ;3 -- ud1lo ud1hi x base + MOV #UMSTARNEXT2,IP ;2 +UMSTARTWO JMP UMSTAR1 ;2 -- ud1lo ud1hi x ud4hi X=ud4lo +UMSTARNEXT2 .word $+2 ; -- ud1lo ud1hi x ud4hi +MPLUS ADD @RSP+,X ;2 -- ud1lo ud1hi x ud4hi X=ud4lo+digit=ud2lo r-- IP adr count base ud3lo + ADDC @RSP+,TOS ;2 -- ud1lo ud1hi x ud2hi TOS=ud4hi+ud3lo+carry=ud2hi r-- IP adr count base + MOV X,4(PSP) ;3 -- ud2lo ud1hi x ud2hi + MOV TOS,2(PSP) ;3 -- ud2lo ud2hi x x r-- IP adr count base + POPM #4,IP ;6 -- ud2lo ud2hi x x W=base, T=count, S=adr, IP=prevIP r-- +TONUMPLUS ADD #1,S ;1 + SUB #1,T ;1 + JNZ TONUMLOOP ;2 -- ud2lo ud2hi x x S=adr+1, T=count-1, W=base 68 cycles char loop +TONUMEND MOV S,0(PSP) ;3 -- ud2lo ud2hi adr2 count2 + MOV T,TOS ;1 -- ud2lo ud2hi adr2 count2 + MOV @IP+,PC ;4 50/82 words/cycles, W = BASE + +; ?NUMBER makes the interface between >NUMBER and INTERPRET; it's a subset of INTERPRET. +; convert a string to a signed number; FORTH 2012 prefixes ' $, %, # are recognized +; digits separator '_' also. +; with DOUBLE_INPUT switched ON, 32 bits signed numbers (with decimal point) are recognized +; with FIXPOINT_INPUT switched ON, Q15.16 signed numbers (with comma) are recognized. +; prefixes ' # % $ - are processed before calling >NUMBER +; chars . , _ are processed as >NUMBER exits +;Z ?NUMBER addr -- n|d -1 if convert ok ; flag Z=0, UF9=1 if double +;Z addr -- addr 0 if convert ko ; flag Z=1 +QNUMBER + .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT + BIC #UF9,SR ;2 reset flag UF9, before use as double number flag + .ENDIF ; + MOV &BASE,T ;3 T=BASE + MOV #0,S ;1 + PUSHM #3,IP ;5 R-- IP sign base (push IP,S,T) + MOV #TONUMEXIT,IP ;2 define >NUMBER return + MOV T,W ;1 W=BASE + SUB #8,PSP ;1 -- x x x x addr + MOV TOS,6(PSP) ;3 -- addr x x x addr + MOV #0,4(PSP) ;3 + MOV #0,2(PSP) ;3 -- addr 0 0 x addr + MOV TOS,S ;1 -- addr ud=0 x x + MOV.B @S+,T ;2 S=addr, T=count +QTICK CMP.B #27h,0(S) ;4 prefix = ' ? + JNZ QNUMLDCHAR ;2 no + MOV.B 1(S),4(PSP) ;5 -- addr ud2lo 0 x x ud2lo = ASCII code of 'char' + CMP.B #3,TOS ;2 string must be 3 chars long + JMP QNUMNEXT ;2 +QNUMLDCHAR MOV.B @S,Y ;2 Y=char +QMINUS SUB.B #'-',Y ;2 -- addr ud=0 x x sign minus ? + JNC QBINARY ;2 if char U< '-' + JNZ TONUMLOOP ;2 if char U> '-' + MOV #-1,2(RSP) ;3 R-- IP sign base + JMP PREFIXED ;2 +QBINARY MOV #2,W ;1 preset base 2 + ADD.B #8,Y ;1 binary prefix ? + JZ PREFIXED ;2 yes +QDECIMAL ADD #8,W ;1 preset base 10 + ADD.B #2,Y ;1 decimal prefix ? + JZ PREFIXED ;2 yes +QHEXA MOV #16,W ;1 preset base 16 + ADD.B #-1,Y ;2 hex prefix ? + JNZ QNUMNEXT ;2 -- addr x x x cnt abort if not recognized prefix +PREFIXED ADD #1,S ;1 + SUB #1,T ;1 S=adr+1 T=count-1 + JMP QNUMLDCHAR ;2 +; ----------------------------------;42 + +TONUMEXIT .word $+2 ; -- addr ud2lo-hi addr2 cnt2 R-- IP sign BASE S=addr2,T=cnt2 ; ----------------------------------; -; decimal point process add-on ; -; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv; - BIC #UF9,SR ;2 reset flag UF9 used here as decimal point flag - MOV.B @TOS,IP ;2 IP = count of chars - ADD TOS,IP ;1 IP = end address - MOV TOS,S ;1 S = ptr - MOV.B #'.',W ;2 W = '.' -SearchDP CMP S,IP ;1 IP U< S ? - JLO SearchDPEND ;2 - CMP.B @S+,W ;2 DP found ? - JNE SearchDP ;2 7~ loop by char -DPfound BIS #UF9,SR ;2 DP found: set flag UF9 -DPrubLoop MOV.B @S+,-2(S) ;4 rub out decimal point - CMP S,IP ;1 and move left one all susbsequent chars - JHS DPrubLoop ;2 7~ loop by char - SUB.B #1,0(TOS) ;3 and decrement count of chars -SearchDPEND -; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^; - MOV #QNUMNEXT,IP ;2 define return from >NUMBER - SUB #8,PSP ;1 -- x x x x c-addr - MOV TOS,6(PSP) ;3 -- c-addr x x x c-addr - MOV #0,4(PSP) ;3 - MOV #0,2(PSP) ;3 -- c-addr ud x c-addr - MOV TOS,W ;1 - MOV.B @W+,TOS ;2 -- c-addr ud x count - MOV W,0(PSP) ;3 -- c-addr ud adr count - MOV.B @W+,X ;2 X=char - CMP.B #'-',X ;2 - JHS QSIGN ;2 speed up for not prefixed numbers -QHEXA SUB.B #'$',X ;2 = 0 ==> "$" : hex number ? - JNZ QBINARY ;2 -- c-addr ud adr count other cases will cause error - MOV #16,&BASE ;4 - JMP PREFIXED ;2 -QBINARY SUB.B #1,X ;1 "%" - "$" - 1 = 0 ==> '%' : hex number ? - JNZ QDECIMAL ;2 - MOV #2,&BASE ;3 - JMP PREFIXED ;2 -QDECIMAL ADD.B #2,X ;1 "#" - "%" + 2 = 0 ==> '#' : decimal number ? - JNZ TONUMBER ;2 that will perform a conversion error - MOV #10,&BASE ;4 -PREFIXED MOV W,0(PSP) ;3 - SUB #1,TOS ;1 -- c-addr ud adr+1 count-1 - MOV.B @W+,X ;2 X=2th char, W=adr - CMP.B #'-',X ;2 -QSIGN JNZ TONUMBER ;2 - MOV #-1,4(RSP) ;3 R-- sign IP BASE - MOV W,0(PSP) ;3 - SUB #1,TOS ;1 -- c-addr ud adr+1 count-1 - JMP TONUMBER ;2 69 + JZ QNUMNEXT ;2 if conversion is ok ; ----------------------------------; - -; ----------------------------------; -QNUMNEXT FORTHtoASM ; -- c-addr ud2lo ud2hi addr2 count2 - ADD #2,PSP ;1 - CMP #0,TOS ;1 -- c-addr ud2lo ud2hi cnt2 n=0 ? conversion is ok ? - .word 0172Ch ;4 -- c-addr ud2lo ud2hi sign POPM S,IP,TOS; TOS = sign flag = {-1;0} - MOV S,&BASE ;3 - JZ QNUMOK ;2 -- c-addr ud2lo ud2hi sign conversion OK -QNUMKO ADD #4,PSP ;1 -- c-addr sign - AND #0,TOS ;1 -- c-addr ff TOS=0 and Z=1 ==> conversion ko - mNEXT ;4 + SUB #2,IP + CMP.B #28h,Y ; rejected char by >NUMBER is a underscore ? + JZ TONUMPLUS ; yes: loopback to >NUMBER to skip char + .IFDEF DOUBLE_NUMBERS ; DOUBLE_NUMBERS = DOUBLE_INPUT | FIXPOINT_INPUT + BIT #UF9,SR ; UF9 already set ? (you have wrongly typed two points) + JNZ QNUMNEXT ; yes, goto QNUMKO + BIS #UF9,SR ;2 set double number flag + .ENDIF + .IFDEF DOUBLE_INPUT + CMP.B #0F7h,Y ;2 rejected char by >NUMBER is a decimal point ? + JZ TONUMPLUS ;2 to terminate conversion + .ENDIF + .IFDEF FIXPOINT_INPUT ; + CMP.B #0F5h,Y ;2 rejected char by >NUMBER is a comma ? + JNZ QNUMNEXT ;2 no, goto QNUMKO ; ----------------------------------; -QNUMOK MOV 2(PSP),4(PSP) ; -- udlo udlo udhi sign - MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back !!! - XOR #-1,TOS ;1 -- udlo udhi inv(sign) - JNZ QDOUBLE ;2 if jump : TOS=-1 and Z=0 ==> conversion ok -Q2NEGATE XOR #-1,TOS ;1 -- udlo udhi tf - XOR #-1,2(PSP) ;3 -- dlo-1 dhi-1 tf - XOR #-1,0(PSP) ;3 -- dlo-1 udhi tf - ADD #1,2(PSP) ;3 -- dlo dhi-1 tf - ADDC #0,0(PSP) ;3 -- dlo dhi tf -QDOUBLE BIT #UF9,SR ;2 decimal point added ? - JNZ QNUMEND ;2 process double numbers - ADD #2,PSP ; -QNUMEND mNEXT ;4 100 words TOS=-1 and Z=0 ==> conversion ok +S15Q16 MOV #0,X ;1 -- addr ud2lo x 0 x init ud2lo' = 0 +S15Q16LOOP MOV X,2(PSP) ;3 -- addr ud2lo ud2lo' ud2lo' x X = 0(PSP) = ud2lo' + SUB.B #1,T ;1 decrement cnt2 + MOV T,X ;1 X = cnt2-1 + ADD S,X ;1 X = end_of_string-1, first... + MOV.B @X,X ;2 X = last char of string, first... + SUB.B #30h,X ;2 char --> digit conversion + CMP.B #10,X ;2 + JNC QS15Q16DIGI ;2 + SUB.B #7,X ;2 + CMP.B #10,X ;2 + JNC S15Q16EOC ;2 +QS15Q16DIGI CMP W,X ;1 R-- IP sign BASE, W=BASE, is X a digit ? + JC S15Q16EOC ;2 -- addr ud2lo ud2lo' x ud2lo' if no + MOV X,0(PSP) ;3 -- addr ud2lo ud2lo' digit x + MOV W,TOS ;1 -- addr ud2lo ud2lo' digit base R-- IP sign base + PUSHM #3,S ;5 PUSH S,T,W: R-- IP sign base addr2 cnt2 base + CALL #MUSMOD ;4 -- addr ud2lo ur uqlo uqhi + POPM #3,S ;5 restore W,T,S: R-- IP sign BASE + JMP S15Q16LOOP ;2 W=cnt +S15Q16EOC MOV 4(PSP),2(PSP) ;5 -- addr ud2lo ud2lo uqlo x ud2lo from >NUMBER part1 becomes here ud2hi=S15 part2 + MOV @PSP,4(PSP) ;4 -- addr ud2lo ud2hi x x uqlo becomes ud2lo + CMP.B #0,T ;1 cnt2 = 0 if end of conversion ok + .ENDIF ; FIXPOINT_INPUT ; +; ----------------------------------;97 +QNUMNEXT POPM #3,IP ;4 -- addr ud2lo-hi x cnt2 POPM T,S,IP S = sign flag = {-1;0} + MOV S,TOS ;1 -- addr ud2lo-hi x sign + MOV T,&BASE ;3 + JZ QNUMOK ;2 -- addr ud2lo-hi x sign flag Z=1: conversion OK +QNUMKO ; flag Z=0 + .IFDEF DOUBLE_NUMBERS + BIC #UF9,SR + .ENDIF + ADD #6,PSP ;1 -- addr sign + AND #0,TOS ;1 -- addr ff TOS=0 and Z=1 ==> conversion ko + MOV @IP+,PC ;4 ; ----------------------------------; + .IFDEF DOUBLE_NUMBERS +QNUMOK ADD #2,PSP ;1 -- addr ud2lo ud2hi sign + MOV 2(PSP),4(PSP) ; -- udlo udlo udhi sign + MOV @PSP+,0(PSP) ;4 -- udlo udhi sign note : PSP is incremented before write back !!! + XOR #-1,TOS ;1 -- udlo udhi inv(sign) + JNZ QDOUBLE ;2 if jump : TOS=-1 and Z=0 ==> conversion ok + XOR #-1,TOS ;1 -- udlo udhi tf +Q2NEGATE XOR #-1,2(PSP) ;3 + XOR #-1,0(PSP) ;3 + ADD #1,2(PSP) ;3 + ADDC #0,0(PSP) ;3 -- dlo dhi tf +QDOUBLE BIT #UF9,SR ;2 -- dlo dhi tf decimal point added ? + JNZ QNUMEND ;2 -- dlo dhi tf leave double + ADD #2,PSP ;1 -- dlo tf leave number, Z=0 +QNUMEND MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok + .ELSE +QNUMOK ADD #4,PSP ;1 -- addr ud2lo sign + MOV @PSP+,0(PSP) ;4 -- udlo sign note : PSP is incremented before write back !!! + XOR #-1,TOS ;1 -- udlo inv(sign) + JNZ QNUMEND ;2 if jump : TOS=-1 and Z=0 ==> conversion ok + XOR #-1,TOS ;1 -- udlo tf TOS=-1 and Z=0 +QNEGATE XOR #-1,0(PSP) ;3 + ADD #1,0(PSP) ;3 -- n tf +QNUMEND MOV @IP+,PC ;4 TOS=-1 and Z=0 ==> conversion ok + .ENDIF ; DOUBLE_NUMBERS + + .ENDIF ; of Hardware/Software MPY - .ENDIF ; MPY +;------------------------------------------------------------------------------- +; DICTIONARY MANAGEMENT +;------------------------------------------------------------------------------- + FORTHWORD "," +; https://forth-standard.org/standard/core/Comma +; , x -- append cell to dict +COMMA MOV &DDP,W ;3 + MOV TOS,0(W) ;3 + ADD #2,&DDP ;3 + MOV @PSP+,TOS ;2 + MOV @IP+,PC ;4 15~ -;https://forth-standard.org/standard/core/EXECUTE -;C EXECUTE i*x xt -- j*x execute Forth word at 'xt' + FORTHWORD "ALLOT" +; https://forth-standard.org/standard/core/ALLOT +; ALLOT n -- allocate n bytes + ADD TOS,&DDP + MOV @PSP+,TOS + MOV @IP+,PC + + .IFDEF CORE_COMPLEMENT FORTHWORD "EXECUTE" -EXECUTE: MOV TOS,W ; 1 put word address into W - MOV @PSP+,TOS ; 2 fetch new TOS - MOV W,PC ; 3 fetch code address into PC - ; 6 = ITC - 1 +; https://forth-standard.org/standard/core/EXECUTE +; EXECUTE i*x xt -- j*x execute Forth word at 'xt' + JMP EXECUTE + .ENDIF -;https://forth-standard.org/standard/core/Comma -;C , x -- append cell to dict - FORTHWORD "," -COMMA: MOV &DDP,W ;3 - ADD #2,&DDP ;3 - MOV TOS,0(W) ;3 - MOV @PSP+,TOS ;2 - mNEXT ;4 15~ - -;https://forth-standard.org/standard/core/LITERAL -;C LITERAL (n|d) -- append single numeric literal if compiling state -; (n|d) -- append double numeric literal if compiling state and if UF9=1 (not ANS) - FORTHWORDIMM "LITERAL" ; immediate -LITERAL: CMP #0,&STATE ;3 - JZ LITERALEND ;2 -LITERAL1 MOV &DDP,W ;3 - ADD #4,&DDP ;3 - MOV #lit,0(W) ;4 - MOV TOS,2(W) ;3 - MOV @PSP+,TOS ;2 - BIT #UF9,SR ;2 - BIC #UF9,SR ;2 - JNZ LITERAL1 ;2 -LITERALEND mNEXT ;4 30~ - -;https://forth-standard.org/standard/core/COUNT -;C COUNT c-addr1 -- adr len counted->adr/len - FORTHWORD "COUNT" -COUNT: SUB #2,PSP ;1 - ADD #1,TOS ;1 - MOV TOS,0(PSP) ;3 - MOV.B -1(TOS),TOS ;3 - mNEXT ;4 15~ + FORTHWORDIMM "LITERAL" ; immediate +; https://forth-standard.org/standard/core/LITERAL +; LITERAL n -- append single numeric literal if compiling state +; d -- append two numeric literals if compiling state and UF9<>0 (not ANS) + .IFDEF DOUBLE_NUMBERS ; are recognized +LITERAL CMP #0,&STATE ;3 + JZ LITERAL2 ;2 if interpreting state, clear UF9 flag then NEXT + MOV TOS,X ;1 +LITERAL1 MOV &DDP,W ;3 X = n|HId + ADD #4,&DDP ;3 + MOV #LIT,0(W) ;4 + MOV X,2(W) ;3 + MOV @PSP+,TOS ;2 + BIT #UF9,SR ;2 double number ? +LITERAL2 BIC #UF9,SR ;2 in all case, clear UF9 + JZ LITERALEND ;2 no + MOV TOS,2(W) ;3 + JMP LITERAL1 ;2 +LITERALEND MOV @IP+,PC ;4 + .ELSE +LITERAL CMP #0,&STATE ;3 + JZ LITERALEND ;2 if interpreting state, do nothing +LITERAL1 MOV &DDP,W ;3 + ADD #4,&DDP ;3 + MOV #LIT,0(W) ;4 + MOV TOS,2(W) ;3 + MOV @PSP+,TOS ;2 +LITERALEND MOV @IP+,PC ;4 + .ENDIF -;C INTERPRET i*x addr u -- j*x interpret given buffer + FORTHWORD "COUNT" +; https://forth-standard.org/standard/core/COUNT +; COUNT c-addr1 -- adr len counted->adr/len +COUNT SUB #2,PSP ;1 + ADD #1,TOS ;1 + MOV TOS,0(PSP) ;3 + MOV.B -1(TOS),TOS ;3 + MOV @IP+,PC ;4 15~ + + FORTHWORD "INTERPRET" +; INTERPRET i*x addr u -- j*x interpret given buffer ; This is the common factor of EVALUATE and QUIT. -; Absent from forth 2012 -; set addr, u as input buffer then parse it word by word -; FORTHWORD "INTERPRET" -INTERPRET: MOV TOS,&SOURCE_LEN ; -- addr u buffer lentgh ==> ticksource variable - MOV @PSP+,&SOURCE_ADR ; -- u buffer address ==> ticksource+2 variable - MOV @PSP+,TOS ; -- - MOV #0,&TOIN ; - mDOCOL ; -INTLOOP .word FBLANK,WORDD ; -- c-addr Z = End Of Line - FORTHtoASM ; - MOV #INTFINDNEXT,IP ;2 define INTFINDNEXT as FIND return - JNZ FIND ;2 if EOL not reached - MOV @RSP+,IP ; -- c-addr - MOV @PSP+,TOS ; -- else EOL is reached - mNEXT ; return to QUIT on EOL - -INTFINDNEXT FORTHtoASM ; -- c-addr fl Z = not found - MOV TOS,W ; W = flag =(-1|0|+1) as (normal|not_found|immediate) - MOV @PSP+,TOS ; -- c-addr - MOV #INTQNUMNEXT,IP ;2 define QNUMBER return - JZ QNUMBER ;2 c-addr -- if not found search a number - MOV #INTLOOP,IP ;2 define (EXECUTE | COMMA) return - XOR &STATE,W ;3 - JZ COMMA ;2 c-addr -- if W xor STATE = 0 compile xt then loop back to INTLOOP - JNZ EXECUTE ;2 c-addr -- if W xor STATE <> 0 execute then loop back to INTLOOP - -INTQNUMNEXT FORTHtoASM ; -- n|c-addr fl Z = not a number, UF9 = double number request - MOV @PSP+,TOS ;2 - MOV #INTLOOP,IP ;2 -- n|c-addr define LITERAL return - JNZ LITERAL ;2 n -- execute LITERAL then loop back to INTLOOP -NotFoundExe ADD.B #1,0(TOS) ;3 c-addr -- Not a Number : incr string count to add '?' - MOV.B @TOS,Y ;2 - ADD TOS,Y ;1 - MOV.B #'?',0(Y) ;5 add '?' to end of word - MOV #FQABORTYES,IP ;2 define COUNT return - JMP COUNT ;2 -- addr len 44 words - -;https://forth-standard.org/standard/core/EVALUATE -; EVALUATE \ i*x c-addr u -- j*x interpret string +; set addr u as input buffer then parse it word by word +INTERPRET mDOCOL ; + .word SETIB ; +INTLOOP .word FBLANK,WORDD ; -- c-addr Z = 1 --> End Of Line + .word $+2 ; + JZ DROPEXIT ;2 Z = 1 --> EOL reached + MOV #INTFINDNEXT,IP ;2 define INTFINDNEXT as FIND return + JMP FIND ;2 +INTFINDNEXT .word $+2 ; -- c-addr fl Z = 1 -->not found + MOV TOS,W ; W = flag =(-1|0|+1) as (normal|not_found|immediate) + MOV @PSP+,TOS ; -- c-addr + MOV #INTQNUMNEXT,IP ;2 define QNUMBER return + JZ QNUMBER ;2 Z = 1 --> not found, search a number + MOV #INTLOOP,IP ;2 define (EXECUTE | COMMA) return + XOR &STATE,W ;3 + JZ COMMA ;2 if W xor STATE = 0 compile xt then loop back to INTLOOP +EXECUTE PUSH TOS ;3 + MOV @PSP+,TOS ;2 -- + MOV @RSP+,PC ;4 xt --> PC + +INTQNUMNEXT .word $+2 ; -- n|c-addr fl Z = 1 --> not a number, SR(UF9) double number request + MOV @PSP+,TOS ;2 + MOV #INTLOOP,IP ;2 -- n|c-addr define LITERAL return + JNZ LITERAL ;2 n -- Z = 0 --> is a number, execute LITERAL then loop back to INTLOOP + +NotFoundexe ADD.B #1,0(TOS) ;3 c-addr -- Z = 1 --> Not a Number : incr string count to add '?' + MOV.B @TOS,Y ;2 Y=count+1 + ADD TOS,Y ;1 Y=end of string addr + MOV.B #'?',0(Y) ;5 add '?' to end of string + MOV #FABORT_TERM,IP ;2 define the return of COUNT + JMP COUNT ;2 -- addr len 35 words +NotFound .word NotFoundExe ; + + .IFDEF CORE_COMPLEMENT FORTHWORD "EVALUATE" -EVALUATE: MOV #SOURCE_LEN,X ;2 - MOV @X+,S ;2 S = SOURCE_LEN - MOV @X+,T ;2 T = SOURCE_ADR - MOV @X+,W ;2 W = TOIN - .word 153Dh ;6 PUSHM IP,S,T,W +; https://forth-standard.org/standard/core/EVALUATE +; EVALUATE \ i*x c-addr u -- j*x interpret string +EVALUATE MOV #SOURCE_LEN,X ;2 + MOV @X+,S ;2 S = SOURCE_LEN + MOV @X+,T ;2 T = SOURCE_ORG + MOV @X+,W ;2 W = TOIN + PUSHM #4,IP ;6 PUSHM IP,S,T,W ASMtoFORTH .word INTERPRET - FORTHtoASM - MOV @RSP+,&TOIN ;4 - MOV @RSP+,&SOURCE_ADR ;4 - MOV @RSP+,&SOURCE_LEN ;4 - MOV @RSP+,IP ;2 - mNEXT - -;https://forth-standard.org/standard/core/QUIT -;c QUIT -- interpret line by line the input stream - FORTHWORD "QUIT" -QUIT: MOV #RSTACK,RSP - MOV #LSTACK,&LEAVEPTR - MOV #0,&STATE - - .IFDEF SD_CARD_LOADER - .IFDEF CONDCOMP - .IFDEF BOOTLOADER -; ----------------------------------; -; BOOTSTRAP TEST ; -; ----------------------------------; - CMP #0,&SAVE_SYSRSTIV ; if WARM - JZ QUIT0 ; no boostrap - BIT.B #SD_CD,&SD_CDIN ; SD_memory in SD_Card module ? - JNZ QUIT0 ; no -; ----------------------------------; -; BOOTSTRAP ; on SYSRSTIV <> 0 -; ----------------------------------; - SUB #2,PSP ; - MOV TOS,0(PSP) ; - MOV &SAVE_SYSRSTIV,TOS ; - MOV #0,&SAVE_SYSRSTIV ; - ASMtoFORTH ; - .word NOECHO ; warning ! your BOOT.4TH must to be finish with ECHO command! - .word XSQUOTE ; -- addr u - .byte 15,"LOAD\34 BOOT.4TH\34" ; issues error 2 if no such file... - .word BRAN,QUIT4 ; -; ----------------------------------; - .ENDIF - .ENDIF - .ENDIF + .word $+2 + MOV @RSP+,&TOIN ;4 + MOV @RSP+,&SOURCE_ORG ;4 + MOV @RSP+,&SOURCE_LEN ;4 + MOV @RSP+,IP + MOV @IP+,PC -QUIT0 MOV #0,&SAVE_SYSRSTIV ; + FORTHWORD "BL" +; https://forth-standard.org/standard/core/BL +; BL -- char an ASCII space + .ENDIF ; CORE_COMPLEMENT +FBLANK CALL rDOCON + .word 20h + +; FORTHWORD "ABORT" +; https://forth-standard.org/standard/core/ABORT +; Empty the data stack and perform the function of QUIT, +; which includes emptying the return stack, without displaying a message. +; ABORT is the common next of WARM and ABORT" +ABORT MOV #PSTACK,PSP ; + MOV #0,TOS ; to set first PSP cell = 0, used next by WARM +; https://forth-standard.org/standard/core/QUIT +; QUIT -- interpret line by line the input stream +QUIT MOV #RSTACK,RSP ; + MOV #LSTACK,&LEAVEPTR ; + MOV #0,&STATE ; ASMtoFORTH -QUIT1 .word XSQUOTE - .byte 3,13,"ok" ; CR + system prompt -QUIT2 .word TYPE,SPACE -QUIT3 .word TIB,DUP,CPL ; -- StringOrg StringOrg maxlenght - .word ACCEPT ; -- StringOrg len' (len' <= maxlenght) - .word SPACE -QUIT4 .word INTERPRET - .word DEPTH,ZEROLESS - .word XSQUOTE - .byte 13,"stack empty! " - .word QABORT - .word lit,FRAM_FULL,HERE,ULESS - .word XSQUOTE - .byte 11,"FRAM full! " - .word QABORT - .word FSTATE,FETCH - .word QBRAN,QUIT1 ; case of interpretion state - .word XSQUOTE ; case of compilation state - .byte 3,13,32,32 ; CR + 2 blanks - .word BRAN,QUIT2 - -;https://forth-standard.org/standard/core/ABORT -;C ABORT i*x -- R: j*x -- clear stack & QUIT - FORTHWORD "ABORT" -ABORT: MOV #PSTACK,PSP - JMP QUIT - -RefillUSBtime .equ int(frequency*2730) ; 2730*frequency ==> word size max value @ 24 MHz - -;Z ?ABORT f c-addr u -- abort & print msg -; FORTHWORD "?ABORT" -QABORT: CMP #0,2(PSP) ; -- f c-addr u flag test -QABORTNO JZ THREEDROP - -QABORTYES MOV #4882h,&YEMIT ; -- c-addr u restore default YEMIT = set ECHO - - .IFDEF SD_CARD_LOADER ; close all handles - MOV &CurrentHdl,T -QABORTCLOSE CMP #0,T - JZ QABORTYESNOECHO - MOV.B #0,HDLB_Token(T) - MOV @T,T - JMP QABORTCLOSE + .IFDEF PROMPT +QUIT1 .word XSQUOTE ; + .byte 5,13,10,"ok " ; CR+LF + Forth prompt +QUIT2 .word TYPE ; display it + .ELSE +QUIT2 .word CR .ENDIF -; ----------------------------------; -QABORTYESNOECHO ; <== WARM jumps here, thus, if NOECHO, TERMINAL can be disconnected without freezing the app -; ----------------------------------; - CALL #QAB_DEFER ; restore default deferred words ....else WARM and SLEEP. -; ----------------------------------; -QABORTTERM ; wait the end of source file downloading -; ----------------------------------; - .IFDEF TERMINALXONXOFF ; - BIT #UCTXIFG,&TERMIFG ; TX buffer empty ? - JZ QABORTTERM ; no - MOV #17,&TERMTXBUF ; yes move XON char into TX_buf - .ENDIF ; - .IFDEF TERMINALCTSRTS ; - BIC.B #RTS,&HANDSHAKOUT ; set /RTS low (connected to /CTS pin of UARTtoUSB bridge) - .ENDIF ; -QABORTLOOP BIC #UCRXIFG,&TERMIFG ; reset TERMIFG(UCRXIFG) - MOV #RefillUSBtime,Y ; 2730*36 = 98 ms : PL2303TA seems to be the slower USB device to refill its TX buffer. -QABUSBLOOPJ MOV #8,X ; 1~ <-------+ -QABUSBLOOPI NOP ; 1~ <---+ | - SUB #1,X ; 1~ | | - JNZ QABUSBLOOPI ; 2~ > 4~ loop -+ | - SUB #1,Y ; 1~ | - JNZ QABUSBLOOPJ ; 2~ --> 36~ loop --+ - BIT #UCRXIFG,&TERMIFG ; 4 new char in TERMXBUF after refill time out ? - JNZ QABORTLOOP ; 2 yes, the input stream (download source file) is still active -; ----------------------------------; -; Display WARM/ABORT message ; -; ----------------------------------; - mDOCOL ; no, the input stream is quiet (end of download source file) - .word XSQUOTE ; -- c-addr u c-addr1 u1 - .byte 4,27,"[7m" ; - .word TYPE ; -- c-addr u set reverse video - .word TYPE ; -- type abort message - .word XSQUOTE ; -- c-addr2 u2 - .byte 4,27,"[0m" ; - .word TYPE ; -- set normal video - .word FORTH,ONLY ; to quit assembler and so to abort any ASSEMBLER definitions - .word DEFINITIONS ; reset CURRENT directory - .word PWR_STATE ; wipe, if exist, not well finished definition and its previous MARKER - .IFDEF LOWERCASE - .word CAPS_ON ; +QUIT3 .word REFILL ; -- org len refill input buffer from ACCEPT (one line) +QUIT4 .word INTERPRET ; interpret this line|string + .word DEPTH,ZEROLESS ; stack empty test + .word XSQUOTE ; ABORT" stack empty! " + .byte 12,"stack empty!" ; + .word QABORT ; see QABORT in forthMSP430FR_TERM_xxx.asm + .word lit,FRAM_FULL ; + .word HERE,ULESS ; FRAM full test + .word XSQUOTE ; ABORT" FRAM full! " + .byte 10,"FRAM full!" ; + .word QABORT ; see QABORT in forthMSP430FR_TERM_xxx.asm + .IFDEF PROMPT + .word LIT,STATE,FETCH ; STATE @ + .word QFBRAN,QUIT1 ; 0= case of interpretion state + .word XSQUOTE ; 0<> case of compilation state + .byte 5,13,10," " ; CR+LF + 3 spaces .ENDIF - .word ABORT ; - -;https://forth-standard.org/standard/core/ABORTq -;C ABORT" i*x flag -- i*x R: j*x -- j*x flag=0 -;C i*x flag -- R: j*x -- flag<>0 + .word BRAN,QUIT2 - FORTHWORDIMM "ABORT\34" ; immediate -ABORTQUOTE: mDOCOL + FORTHWORDIMM "ABORT\34" ; immediate +; https://forth-standard.org/standard/core/ABORTq +; ABORT" i*x flag -- i*x R: j*x -- j*x flag=0 +; i*x flag -- R: j*x -- flag<>0 +; ABORT" " displays nothing +ABORTQUOTE mDOCOL .word SQUOTE - .word lit,QABORT,COMMA + .word lit,QABORT,COMMA ; see QABORT in forthMSP430FR_TERM_xxx.asm .word EXIT - -;https://forth-standard.org/standard/core/Tick -;C ' -- xt find word in dictionary and leave on stack its execution address - FORTHWORD "'" -TICK: mDOCOL ; separator -- xt - .word FBLANK,WORDD,FIND ; Z=1 if not found - .word QBRAN,NotFound - .word EXIT -NotFound .word NotFoundExe ; in INTERPRET - -;https://forth-standard.org/standard/block/bs -; \ -- backslash -; everything up to the end of the current line is a comment. - FORTHWORDIMM "\\" ; immediate -BACKSLASH: MOV &SOURCE_LEN,&TOIN ; - mNEXT - ;------------------------------------------------------------------------------- ; COMPILER ;------------------------------------------------------------------------------- + FORTHWORD "'" +; https://forth-standard.org/standard/core/Tick +; ' -- xt find word in dictionary and leave on stack its execution address +TICK mDOCOL + .word FBLANK,WORDD,FIND + .word QFBRAN,NotFound ; see INTERPRET + .word EXIT -;https://forth-standard.org/standard/core/Bracket -;C [ -- enter interpretative state - FORTHWORDIMM "[" ; immediate -LEFTBRACKET: MOV #0,&STATE - mNEXT - -;https://forth-standard.org/standard/core/right-bracket -;C ] -- enter compiling state - FORTHWORD "]" -RIGHTBRACKET: MOV #-1,&STATE - mNEXT - -;https://forth-standard.org/standard/core/BracketTick -;C ['] -- find word & compile it as literal - FORTHWORDIMM "[']" ; immediate word, i.e. word executed also during compilation -BRACTICK: mDOCOL + FORTHWORDIMM "[']" ; immediate word, i.e. word executed during compilation +; https://forth-standard.org/standard/core/BracketTick +; ['] -- find word & compile it as literal +BRACTICK mDOCOL .word TICK ; get xt of .word lit,lit,COMMA ; append LIT action .word COMMA,EXIT ; append xt literal -;https://forth-standard.org/standard/core/DEFERStore -;C DEFER! xt CFA_DEFER -- ; store xt to the address after DODEFER -; FORTHWORD "DEFER!" -DEFERSTORE: MOV @PSP+,2(TOS) ; -- CFA_DEFER xt --> [CFA_DEFER+2] - MOV @PSP+,TOS ; -- - mNEXT - -;https://forth-standard.org/standard/core/IS -;C IS xt -- -; used as is : -; DEFER DISPLAY create a "do nothing" definition (2 CELLS) -; inline command : ' U. IS DISPLAY U. becomes the runtime of the word DISPLAY -; or in a definition : ... ['] U. IS DISPLAY ... -; KEY, EMIT, CR, ACCEPT and WARM are DEFERred words - -; as IS replaces the PFA value of a "PFA word", it may be also used with VARIABLE and CONSTANT words... - - FORTHWORDIMM "IS" ; immediate -IS: mDOCOL - .word FSTATE,FETCH - .word QBRAN,IS_EXEC -IS_COMPILE .word BRACTICK ; find the word, compile its CFA as literal - .word lit,DEFERSTORE,COMMA ; compile DEFERSTORE - .word EXIT -IS_EXEC .word TICK,DEFERSTORE ; find the word, leave its CFA on the stack and execute DEFERSTORE - .word EXIT + FORTHWORDIMM "[" ; immediate +; https://forth-standard.org/standard/core/Bracket +; [ -- enter interpretative state +LEFTBRACKET + MOV #0,&STATE + MOV @IP+,PC + + FORTHWORD "]" +; https://forth-standard.org/standard/core/right-bracket +; ] -- enter compiling state +RIGHTBRACKET + MOV #-1,&STATE + MOV @IP+,PC + + FORTHWORDIMM "\\" ; immediate +; https://forth-standard.org/standard/block/bs +; \ -- backslash +; everything up to the end of the current line is a comment. +BACKSLASH MOV &SOURCE_LEN,&TOIN ; + MOV @IP+,PC -;https://forth-standard.org/standard/core/IMMEDIATE -;C IMMEDIATE -- make last definition immediate - FORTHWORD "IMMEDIATE" -IMMEDIATE: MOV &LAST_NFA,W - BIS.B #80h,0(W) - mNEXT - -;https://forth-standard.org/standard/core/RECURSE -;C RECURSE -- recurse to current definition (compile current definition) - FORTHWORDIMM "RECURSE" ; immediate -RECURSE: MOV &DDP,X ; - MOV &LAST_CFA,0(X) ; - ADD #2,&DDP ; - mNEXT - - -;https://forth-standard.org/standard/core/POSTPONE - FORTHWORDIMM "POSTPONE" ; immediate -POSTPONE: mDOCOL + FORTHWORDIMM "POSTPONE" +; https://forth-standard.org/standard/core/POSTPONE +POSTPONE mDOCOL .word FBLANK,WORDD,FIND,QDUP - .word QBRAN,NotFound - .word ZEROLESS ; immediate ? - .word QBRAN,POST1 ; yes - .word lit,lit,COMMA,COMMA - .word lit,COMMA -POST1: .word COMMA,EXIT - - -;;Z ?REVEAL -- if no stack mismatch, link this created word in the CURRENT vocabulary -; FORTHWORD "REVEAL" -QREVEAL: CMP PSP,&LAST_PSP ; Check SP with its saved value by : - JZ GOOD_CSP ; if no stack mismatch. See MARKER below -BAD_CSP mDOCOL - .word XSQUOTE - .byte 15,"stack mismatch!" -FQABORTYES .word QABORTYES + .word QFBRAN,NotFound ; see INTERPRET + .word ZEROLESS ; immediate word ? + .word QFBRAN,POST1 ; if immediate + .word lit,lit,COMMA ; else compile lit + .word COMMA ; compile xt + .word lit,COMMA ; CFA of COMMA +POST1 .word COMMA,EXIT ; then compile: if immediate xt of word found else CFA of COMMA -; HEADER create an header for a new word. Max count of chars = 126 -; common code for VARIABLE, CONSTANT, CREATE, DEFER, :, MARKER, CODE, ASM. -; don't link created word in vocabulary. -HEADER: mDOCOL - .word CELLPLUSALIGN ; ALIGN then make room for LFA + FORTHWORD ":" +; https://forth-standard.org/standard/core/Colon +; : -- begin a colon definition +; HEADER is CALLed by all compiling words +COLON PUSH #COLONNEXT ;3 define COLONNEXT as HEADER return +;-----------------------------------; +HEADER BIT #1,&DDP ;3 carry set if odd + ADDC #2,&DDP ;4 (DP+2|DP+3) bytes, make room for LFA + mDOCOL ; .word FBLANK,WORDD ; - FORTHtoASM ; -- HERE HERE is the NFA of this new word - MOV TOS,Y ; - MOV.B @TOS+,W ; -- xxx W=Count_of_chars Y=NFA - BIS.B #1,W ; -- xxx W=count is always odd - ADD.B #1,W ; -- xxx W=add one byte for length - ADD Y,W ; -- xxx W=Aligned_CFA - MOV &CURRENT,X ; -- xxx X=VOC_BODY of CURRENT Y=NFA - .SWITCH THREADS + .word $+2 ; -- HERE HERE is the NFA of this new word + MOV @RSP+,IP ; + MOV TOS,Y ; -- NFA Y=NFA + MOV.B @TOS+,W ; -- NFA+1 W=Count_of_chars + BIS.B #1,W ; W=count is always odd + ADD.B #1,W ; W=add one byte for length + ADD Y,W ; W=Aligned_CFA + MOV &CURRENT,X ; X=VOC_BODY of CURRENT + .SWITCH THREADS ; .CASE 1 ; nothing to do .ELSECASE ; multithreading add 5~ 4words - MOV.B @TOS,TOS ; -- xxx TOS=first CHAR of new word - AND #(THREADS-1)*2,TOS ; -- xxx TOS= Thread offset - ADD TOS,X ; -- xxx TOS= Thread X=VOC_PFAx = thread x of VOC_PFA of CURRENT - .ENDCASE - MOV Y,&LAST_NFA ; -- xxx NFA --> LAST_NFA used by QREVEAL, IMMEDIATE - MOV X,&LAST_THREAD ; -- xxx VOC_PFAx --> LAST_THREAD used by QREVEAL - MOV W,&LAST_CFA ; -- xxx HERE=CFA --> LAST_CFA used by DOES>, RECURSE - ADD #4,W ; -- xxx by default make room for two words... - MOV W,&DDP ; -- xxx - MOV @PSP+,TOS ; -- - MOV @RSP+,IP - MOV @RSP+,PC ; 23 words, W is the new DDP value ) - ; X is LAST_THREAD > used by VARIABLE, CONSTANT, CREATE, DEFER and : - ; Y is NFA ) + MOV.B @TOS,TOS ; -- char TOS=first CHAR of new word + AND #(THREADS-1)*2,TOS ; -- offset TOS= Thread offset + ADD TOS,X ; X=VOC_PFAx = thread x of VOC_PFA of CURRENT + .ENDCASE ; + MOV @PSP+,TOS ; -- +HEADEREND MOV Y,&LAST_NFA ; NFA --> LAST_NFA used by QREVEAL, IMMEDIATE, MARKER + MOV X,&LAST_THREAD ; VOC_PFAx --> LAST_THREAD used by QREVEAL + MOV W,&LAST_CFA ; HERE=CFA --> LAST_CFA used by DOES>, RECURSE + MOV PSP,&LAST_PSP ; save PSP for check compiling, used by QREVEAL + ADD #4,W ; by default make room for two words... + MOV W,&DDP ; + MOV @RSP+,PC ; RET W is the new DP value ) + ; X is LAST_THREAD > used by compiling words: CREATE, DEFER, :... +COLONNEXT ; Y is NFA ) + .SWITCH DTC ; Direct Threaded Code select + .CASE 1 ; + MOV #1284h,-4(W) ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL) + SUB #2,&DDP ; + .CASE 2 ; + MOV #120Dh,-4(W) ; compile PUSH IP 3~ + MOV #1284h,-2(W) ; compile CALL R4 = rDOCOL ([rDOCOL] = EXIT) + .CASE 3 ; + MOV #120Dh,-4(W) ; compile PUSH IP 3~ + MOV #400Dh,-2(W) ; compile MOV PC,IP 1~ + MOV #522Dh,0(W) ; compile ADD #4,IP 1~ + MOV #4D30h,+2(W) ; compile MOV @IP+,PC 4~ + ADD #4,&DDP ; + .ENDCASE ; + MOV #-1,&STATE ; enter compiling state + MOV @IP+,PC ; +;-----------------------------------; + +;;Z ?REVEAL -- if no stack mismatch, link this new word in the CURRENT vocabulary +QREVEAL CMP PSP,&LAST_PSP ; Check SP with its saved value by :, :NONAME, CODE... + JNZ BAD_CSP ; if stack mismatch. +GOOD_CSP MOV &LAST_NFA,Y ; + MOV &LAST_THREAD,X ; +REVEAL MOV @X,-2(Y) ; [LAST_THREAD] --> LFA (for NONAME: [LAST_THREAD] --> unused PA reg) + MOV Y,0(X) ; LAST_NFA --> [LAST_THREAD] (for NONAME: LAST_NFA --> unused PA reg) + MOV @IP+,PC -;https://forth-standard.org/standard/core/VARIABLE -;C VARIABLE -- define a Forth VARIABLE - FORTHWORD "VARIABLE" -VARIABLE: CALL #HEADER ; W = DDP = CFA + 2 words - MOV #DOVAR,-4(W) ; CFA = DOVAR - JMP REVEAL ; PFA = undefined +BAD_CSP mDOCOL + .word XSQUOTE + .byte 15,"stack mismatch!" +FABORT_TERM .word ABORT_TERM -;https://forth-standard.org/standard/core/CONSTANT -;C CONSTANT n -- define a Forth CONSTANT (it's also an alias of VALUE) - FORTHWORD "CONSTANT" -CONSTANT: CALL #HEADER ; W = DDP = CFA + 2 words - MOV #DOCON,-4(W) ; CFA = DOCON - MOV TOS,-2(W) ; PFA = n - MOV @PSP+,TOS - JMP REVEAL - -;;https://forth-standard.org/standard/core/VALUE -;;( x "name" -- ) define a Forth VALUE -;;Skip leading space delimiters. Parse name delimited by a space. -;;Create a definition for name with the execution semantics defined below, -;;with an initial value equal to x. -; -;;name Execution: ( -- x ) -;;Place x on the stack. The value of x is that given when name was created, -;;until the phrase x TO name is executed, causing a new value of x to be assigned to name. -; -;;TO name Run-time: ( x -- ) -;;Assign the value x to name. -; -; FORTHWORD "VALUE" -; JMP CONSTANT -; -; FORTHWORDIMM "TO" -; JMP IS + FORTHWORDIMM ";" +; https://forth-standard.org/standard/core/Semi +; ; -- end a colon definition +SEMICOLON CMP #0,&STATE ; if interpret mode, semicolon becomes a comment identifier + JZ BACKSLASH ; tip: ";" is transparent to the preprocessor, so semicolon comments are kept in file.4th + mDOCOL ; compile mode + .word lit,EXIT,COMMA + .word QREVEAL,LEFTBRACKET,EXIT + FORTHWORD "IMMEDIATE" +; https://forth-standard.org/standard/core/IMMEDIATE +; IMMEDIATE -- make last definition immediate +IMMEDIATE MOV &LAST_NFA,Y ; Y = NFA|unused_PA_reg as lure for :NONAME + BIS.B #BIT7,0(Y) ; + MOV @IP+,PC -;https://forth-standard.org/standard/core/CREATE -;C CREATE -- define a CONSTANT with its next address + FORTHWORD "CREATE" +; https://forth-standard.org/standard/core/CREATE +; CREATE -- define a CONSTANT with its next address ; Execution: ( -- a-addr ) ; a-addr is the address of name's data field ; ; the execution semantics of name may be extended by using DOES> - FORTHWORD "CREATE" -CREATE: CALL #HEADER ; -- W = DDP - MOV #DOCON,-4(W) ;4 CFA = DOCON - MOV W,-2(W) ;3 PFA = next address - JMP REVEAL +CREATE CALL #HEADER ; -- W = DDP + MOV #1286h,-4(W) ;4 -4(W) = CFA = CALL R6 = rDOCON + MOV W,-2(W) ;3 -2(W) = PFA = W = next address + JMP REVEAL ; to link the definition in vocabulary -;https://forth-standard.org/standard/core/DOES -;C DOES> -- set action for the latest CREATEd definition + .IFDEF CORE_COMPLEMENT FORTHWORD "DOES>" -DOES: MOV &LAST_CFA,W ; W = CFA of latest CREATEd word that becomes a master word - MOV #DODOES,0(W) ; replace old CFA (DOCON) by new CFA (DODOES) - MOV IP,2(W) ; replace old PFA by the address after DOES> as execution address - MOV @RSP+,IP ; exit of the new created word -NEXTADR mNEXT +; https://forth-standard.org/standard/core/DOES +; DOES> -- set action for the latest CREATEd definition +DOES MOV &LAST_CFA,W ; W = CFA of CREATEd word + MOV #1285h,0(W) ; replace old CFA of CREATE by new CFA CALL R5 = rDODOES + MOV IP,2(W) ; replace PFA by the address after DOES> as execution address + MOV @RSP+,IP ; + MOV @IP+,PC ; exit of the new created word -;https://forth-standard.org/standard/core/DEFER -;C DEFER "name" -- -;Skip leading space delimiters. Parse name delimited by a space. -;Create a definition for name with the execution semantics defined below. - -;name Execution: -- -;Execute the xt that name is set to execute, i.e. NEXT (nothing), -;until the phrase ' word IS name is executed, causing a new value of xt to be assigned to name. + FORTHWORD "CONSTANT" +;https://forth-standard.org/standard/core/CONSTANT +;C CONSTANT n -- define a Forth CONSTANT +CONSTANT CALL #HEADER ; W = DDP = CFA + 2 words + MOV #1286h,-4(W) ; CFA = CALL R6 = rDOCON + MOV TOS,-2(W) ; PFA = n + MOV @PSP+,TOS ; -- + JMP REVEAL ; to link the definition in vocabulary + FORTHWORD "VARIABLE" +;https://forth-standard.org/standard/core/VARIABLE +;C VARIABLE -- define a Forth VARIABLE +VARIABLE CALL #HEADER ; W = DDP = CFA + 2 words + MOV #1287h,-4(W) ; CFA = CALL R7 = rDOVAR, PFA is undefined + JMP REVEAL ; to link created VARIABLE in vocabulary + + .ENDIF ; CORE_COMPLEMENT + + .IFDEF DEFERRED + FORTHWORD ":NONAME" +; https://forth-standard.org/standard/core/ColonNONAME +; :NONAME -- xt +; W is DP +; X is the LAST_THREAD lure value for REVEAL +; Y is the LAST_NFA lure value for REVEAL and IMMEDIATE +; ...because we don't want to modify the word set ! + PUSH #COLONNEXT ; define COLONNEXT as HEADERLESS RET +HEADERLESS SUB #2,PSP ; common part of :NONAME and CODENNM + MOV TOS,0(PSP) ; + MOV &DDP,W ; + BIT #1,W ; + ADDC #0,W ; W = aligned CFA + MOV W,TOS ; -- xt aligned CFA of :NONAME | CODENNM + MOV #210h,X ; X = 210h = unused PA register address (lure for REVEAL) + MOV X,Y ;1 + ADD #2,Y ;1 Y = 212h = unused PA register address (lure for REVEAL and IMMEDIATE) + JMP HEADEREND ; + +; https://forth-standard.org/standard/core/DEFER +; Skip leading space delimiters. Parse name delimited by a space. +; Create a definition for name with the execution semantics defined below. +; +; name Execution: -- +; Execute the xt that name is set to execute, i.e. NEXT (nothing), +; until the phrase ' word IS name is executed, causing a new value of xt to be assigned to name. FORTHWORD "DEFER" -DEFER: CALL #HEADER - MOV #4030h,-4(W) ;4 CFA = MOV @PC+,PC = BR... - MOV #NEXTADR,-2(W) ;4 PFA = address of NEXT: created word does nothing by default - JMP REVEAL + CALL #HEADER + MOV #4030h,-4(W) ;4 first CELL = MOV @PC+,PC = BR... + MOV #NEXT_ADR,-2(W) ;3 second CELL = ...mNEXT : do nothing by default + JMP REVEAL ; to link created word in vocabulary + +; DEFER! ( xt CFA_DEFERed_WORD -- ) +; FORTHWORD "DEFER!" +DEFERSTORE MOV @PSP+,2(TOS) ; -- CFA_DEFERed_WORD xt --> [CFA_DEFERed_WORD+2] + MOV @PSP+,TOS ; -- + MOV @IP+,PC ; + +; IS xt -- +; used like this: +; DEFER DISPLAY create a "do nothing" definition (2 CELLS) +; inline command : ' U. IS DISPLAY U. becomes the runtime of the word DISPLAY +; or in a definition : ... ['] U. IS DISPLAY ... +; KEY, EMIT, CR, ACCEPT and WARM are examples of DEFERred words + FORTHWORDIMM "IS" ; immediate +IS PUSH IP + CMP #0,&STATE + JZ IS_EXEC +IS_COMPILE ASMtoFORTH + .word BRACTICK ; find the word, compile its CFA as literal + .word lit,DEFERSTORE,COMMA ; compile DEFERSTORE + .word EXIT +IS_EXEC ASMtoFORTH + .word TICK,DEFERSTORE ; find the word, leave its CFA on the stack and execute DEFERSTORE + .word EXIT + .ENDIF ; DEFERRED -;https://forth-standard.org/standard/core/Colon -;C : -- begin a colon definition - FORTHWORD ":" - COLON: CALL #HEADER + .IFDEF MSP430ASSEMBLER + FORTHWORD "CODE" ; a CODE word must be finished with ENDCODE +ASMCODE CALL #HEADER ; (that makes room for CFA and PFA) +ASMCODE1 SUB #4,&DDP ; remove default room for CFA and PFA +ASMCODE2 + .IFDEF EXTENDED_ASM + MOV #0,&RPT_WORD ; clear RPT instruction + .ENDIF + mDOCOL + .word ALSO,ASSEMBLER,EXIT + + .IFDEF DEFERRED + FORTHWORD "CODENNM" ; CODENoNaMe is the assembly counterpart of :NONAME +CODENNM PUSH #ASMCODE1 ; define HEADERLESS return + JMP HEADERLESS ; that makes room for CFA and PFA + .ENDIF + asmword "ENDCODE" ; test PSP balancing then restore previous context +ENDCODE mDOCOL + .word QREVEAL,PREVIOUS,EXIT + +; ASM and ENDASM are used to define an assembler word which is not executable by FORTH interpreter +; i.e. typically an assembler word called by CALL and ended by RET, or an interrupt routine ended by RETI. +; ASM words are only usable in another ASSEMBLER words +; any ASM word must be finished with ENDASM. +; The template " ASM ... COLON ... ; " or any other finishing by SEMICOLON is +; prohibited because it doesn't restore CURRENT. + FORTHWORD "ASM" + MOV #BODYASSEMBLER,&CURRENT ; select ASSEMBLER word set to link this ASM word + JMP ASMCODE + + asmword "ENDASM" ; end of an ASM word + mDOCOL ; select PREVIOUS word set as CURRENT word set + .word ENDCODE,DEFINITIONS,EXIT + +; here are words used to switch from/to FORTH to/from ASSEMBLER + asmword "COLON" ; compile DOCOL, remove ASSEMBLER from CONTEXT, switch to compilation state + MOV &DDP,W .SWITCH DTC .CASE 1 - MOV #DOCOL1,-4(W) ; compile CALL rDOCOL - SUB #2,&DDP + MOV #1284h,0(W) ; compile CALL R4 = rDOCOL ([rDOCOL] = XDOCOL) + ADD #2,&DDP .CASE 2 - MOV #DOCOL1,-4(W) ; compile PUSH IP 3~ - MOV #DOCOL2,-2(W) ; compile CALL rEXIT + MOV #120Dh,0(W) ; compile PUSH IP +COLON1 MOV #1284h,2(W) ; compile CALL R4 = rDOCOL + ADD #4,&DDP .CASE 3 ; inlined DOCOL - MOV #DOCOL1,-4(W) ; compile PUSH IP 3~ - MOV #DOCOL2,-2(W) ; compile MOV PC,IP 1~ - MOV #DOCOL3,0(W) ; compile ADD #4,IP 1~ - MOV #NEXT,+2(W) ; compile MOV @IP+,PC 4~ - ADD #4,&DDP - .ENDCASE ; of DTC - MOV #-1,&STATE ; enter compiling state -SAVE_PSP MOV PSP,&LAST_PSP ; save PSP for check compiling, used by QREVEAL - mNEXT - -;https://forth-standard.org/standard/core/Semi -;C ; -- end a colon definition - FORTHWORDIMM ";" ; immediate -SEMICOLON: CMP #0,&STATE ; interpret mode : semicolon becomes a comment separator - JZ BACKSLASH ; tip: ";" is transparent to the preprocessor, so semicolon comments are kept in file.4th - mDOCOL ; compile mode - .word lit,EXIT,COMMA - .word QREVEAL,LEFTBRACKET,EXIT + MOV #120Dh,0(W) ; compile PUSH IP +COLON1 MOV #400Dh,2(W) ; compile MOV PC,IP + MOV #522Dh,4(W) ; compile ADD #4,IP + MOV #4D30h,6(W) ; compile MOV @IP+,PC + ADD #8,&DDP ; + .ENDCASE ; DTC + +COLON2 MOV #-1,&STATE ; enter in compile state + MOV #PREVIOUS,PC ; restore previous state of CONTEXT (remove ASSEMBLER) + + asmword "LO2HI" ; same as COLON but without saving IP + .SWITCH DTC + .CASE 1 ; compile 2 words + MOV &DDP,W + MOV #12B0h,0(W) ; compile CALL #EXIT, 2 words 4+6=10~ + MOV #EXIT,2(W) + ADD #4,&DDP + JMP COLON2 + .ELSECASE ; CASE 2 : compile 1 word, CASE 3 : compile 3 words + SUB #2,&DDP ; to skip PUSH IP + MOV &DDP,W + JMP COLON1 + .ENDCASE + + FORTHWORDIMM "HI2LO" ; immediate, switch to low level, set interpretation state, add ASSEMBLER context + mDOCOL + .word HERE,CELLPLUS,COMMA ; compile HERE+2 + .word LEFTBRACKET ; switch to interpret state + .word ASMCODE2 ; add ASSEMBLER in context + .word EXIT + + .ENDIF ; MSP430ASSEMBLER .IFDEF CONDCOMP -;; CORE EXT MARKER -;;( "name" -- ) -;;Skip leading space delimiters. Parse name delimited by a space. Create a definition for name -;;with the execution semantics defined below. - -;;name Execution: ( -- ) -;;Restore all dictionary allocation and search order pointers to the state they had just prior to the -;;definition of name. Remove the definition of name and all subsequent definitions. Restoration -;;of any structures still existing that could refer to deleted definitions or deallocated data space is -;;not necessarily provided. No other contextual information such as numeric base is affected - -MARKER_DOES FORTHtoASM ; execution part - MOV @RSP+,IP ; -- PFA - MOV @TOS+,&INIVOC ; set VOC_LINK value for RST_STATE - MOV @TOS,&INIDP ; set DP value for RST_STATE - MOV @PSP+,TOS ; -- - JMP RST_STATE ; execute RST_STATE, PWR_STATE then STATE_DOES - - FORTHWORD "MARKER" ; definition part - CALL #HEADER ;4 W = DP+4 - MOV #DODOES,-4(W) ;4 CFA = DODOES - MOV #MARKER_DOES,-2(W) ;4 PFA = MARKER_DOES - MOV &LASTVOC,0(W) ;5 [BODY] = VOCLINK to be restored - SUB #2,Y ;1 Y = LFA - MOV Y,2(W) ;3 [BODY+2] = LFA = DP to be restored - ADD #4,&DDP ;3 - - .ENDIF ; CONDCOMP - -GOOD_CSP MOV &LAST_NFA,Y ; - MOV &LAST_THREAD,X ; -REVEAL MOV @X,-2(Y) ; [LAST_THREAD] --> LFA - MOV Y,0(X) ; LAST_NFA --> [LAST_THREAD] - mNEXT - - -; ---------------------------------------------------------------------- +; ------------------------------------------------------------------------------ +; forthMSP430FR : CONDITIONNAL COMPILATION +; ------------------------------------------------------------------------------ + .include "forthMSP430FR_CONDCOMP.asm" + .ENDIF + + .IFDEF CORE_COMPLEMENT +; ------------------------------------------------------------------------------ ; CONTROL STRUCTURES -; ---------------------------------------------------------------------- +; ------------------------------------------------------------------------------ ; THEN and BEGIN compile nothing ; DO compile one word ; IF, ELSE, AGAIN, UNTIL, WHILE, REPEAT, LOOP & +LOOP compile two words ; LEAVE compile three words -;https://forth-standard.org/standard/core/IF -;C IF -- IFadr initialize conditional forward branch FORTHWORDIMM "IF" ; immediate -IFF: SUB #2,PSP ; - MOV TOS,0(PSP) ; - MOV &DDP,TOS ; -- HERE - ADD #4,&DDP ; compile one word, reserve one word - MOV #QBRAN,0(TOS) ; -- HERE compile QBRAN -CELLPLUS ADD #2,TOS ; -- HERE+2=IFadr - mNEXT - - -;https://forth-standard.org/standard/core/ELSE -;C ELSE IFadr -- ELSEadr resolve forward IF branch, leave ELSEadr on stack +; https://forth-standard.org/standard/core/IF +; IF -- IFadr initialize conditional forward branch +IFF SUB #2,PSP ; + MOV TOS,0(PSP) ; + MOV &DDP,TOS ; -- HERE + ADD #4,&DDP ; compile one word, reserve one word + MOV #QFBRAN,0(TOS) ; -- HERE compile QFBRAN + .ENDIF ; CORE_COMPLEMENT +CELLPLUS ADD #2,TOS ; -- HERE+2=IFadr + MOV @IP+,PC + + .IFDEF CORE_COMPLEMENT FORTHWORDIMM "ELSE" ; immediate -ELSS: ADD #4,&DDP ; make room to compile two words - MOV &DDP,W ; W=HERE+4 - MOV #bran,-4(W) - MOV W,0(TOS) ; HERE+4 ==> [IFadr] - SUB #2,W ; HERE+2 - MOV W,TOS ; -- ELSEadr - mNEXT - -;https://forth-standard.org/standard/core/THEN -;C THEN IFadr -- resolve forward branch +; https://forth-standard.org/standard/core/ELSE +; ELSE IFadr -- ELSEadr resolve forward IF branch, leave ELSEadr on stack +ELSS ADD #4,&DDP ; make room to compile two words + MOV &DDP,W ; W=HERE+4 + MOV #BRAN,-4(W) + MOV W,0(TOS) ; HERE+4 ==> [IFadr] + SUB #2,W ; HERE+2 + MOV W,TOS ; -- ELSEadr + MOV @IP+,PC + FORTHWORDIMM "THEN" ; immediate -THEN: MOV &DDP,0(TOS) ; -- IFadr - MOV @PSP+,TOS ; -- - mNEXT +; https://forth-standard.org/standard/core/THEN +; THEN IFadr -- resolve forward branch +THEN MOV &DDP,0(TOS) ; -- IFadr + MOV @PSP+,TOS ; -- + MOV @IP+,PC -;https://forth-standard.org/standard/core/BEGIN -;C BEGIN -- BEGINadr initialize backward branch FORTHWORDIMM "BEGIN" ; immediate -BEGIN: MOV #HERE,PC ; BR HERE +; https://forth-standard.org/standard/core/BEGIN +; BEGIN -- BEGINadr initialize backward branch + MOV #HERE,PC ; -- HERE -;https://forth-standard.org/standard/core/UNTIL -;C UNTIL BEGINadr -- resolve conditional backward branch FORTHWORDIMM "UNTIL" ; immediate -UNTIL: MOV #qbran,X -UNTIL1 ADD #4,&DDP ; compile two words - MOV &DDP,W ; W = HERE - MOV X,-4(W) ; compile Bran or qbran at HERE - MOV TOS,-2(W) ; compile bakcward adr at HERE+2 - MOV @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/AGAIN -;X AGAIN BEGINadr -- resolve uncondionnal backward branch +; https://forth-standard.org/standard/core/UNTIL +; UNTIL BEGINadr -- resolve conditional backward branch +UNTIL MOV #QFBRAN,X +UNTIL1 ADD #4,&DDP ; compile two words + MOV &DDP,W ; W = HERE + MOV X,-4(W) ; compile Bran or QFBRAN at HERE + MOV TOS,-2(W) ; compile bakcward adr at HERE+2 + MOV @PSP+,TOS + MOV @IP+,PC + FORTHWORDIMM "AGAIN" ; immediate -AGAIN: MOV #bran,X - JMP UNTIL1 +; https://forth-standard.org/standard/core/AGAIN +;X AGAIN BEGINadr -- resolve uncondionnal backward branch +AGAIN MOV #BRAN,X + JMP UNTIL1 -;https://forth-standard.org/standard/core/WHILE -;C WHILE BEGINadr -- WHILEadr BEGINadr FORTHWORDIMM "WHILE" ; immediate -WHILE: mDOCOL +; https://forth-standard.org/standard/core/WHILE +; WHILE BEGINadr -- WHILEadr BEGINadr +WHILE mDOCOL .word IFF,SWAP,EXIT -;https://forth-standard.org/standard/core/REPEAT -;C REPEAT WHILEadr BEGINadr -- resolve WHILE loop FORTHWORDIMM "REPEAT" ; immediate -REPEAT: mDOCOL +; https://forth-standard.org/standard/core/REPEAT +; REPEAT WHILEadr BEGINadr -- resolve WHILE loop +REPEAT mDOCOL .word AGAIN,THEN,EXIT -;https://forth-standard.org/standard/core/DO -;C DO -- DOadr L: -- 0 FORTHWORDIMM "DO" ; immediate -DO: SUB #2,PSP ; - MOV TOS,0(PSP) ; - ADD #2,&DDP ; make room to compile xdo - MOV &DDP,TOS ; -- HERE+2 - MOV #xdo,-2(TOS) ; compile xdo - ADD #2,&LEAVEPTR ; -- HERE+2 LEAVEPTR+2 - MOV &LEAVEPTR,W ; - MOV #0,0(W) ; -- HERE+2 L-- 0 - mNEXT - -;https://forth-standard.org/standard/core/LOOP -;C LOOP DOadr -- L-- an an-1 .. a1 0 +; https://forth-standard.org/standard/core/DO +; DO -- DOadr L: -- 0 +DO SUB #2,PSP ; + MOV TOS,0(PSP) ; + ADD #2,&DDP ; make room to compile xdo + MOV &DDP,TOS ; -- HERE+2 + MOV #xdo,-2(TOS) ; compile xdo + ADD #2,&LEAVEPTR ; -- HERE+2 LEAVEPTR+2 + MOV &LEAVEPTR,W ; + MOV #0,0(W) ; -- HERE+2 L-- 0 + MOV @IP+,PC + + FORTHWORD "I" +; https://forth-standard.org/standard/core/I +; I -- n R: sys1 sys2 -- sys1 sys2 +; get the innermost loop index +II SUB #2,PSP ;1 make room in TOS + MOV TOS,0(PSP) ;3 + MOV @RSP,TOS ;2 index = loopctr - fudge + SUB 2(RSP),TOS ;3 + MOV @IP+,PC ;4 13~ + FORTHWORDIMM "LOOP" ; immediate -LOO: MOV #xloop,X -ENDLOOP ADD #4,&DDP ; make room to compile two words - MOV &DDP,W - MOV X,-4(W) ; xloop --> HERE - MOV TOS,-2(W) ; DOadr --> HERE+2 +; https://forth-standard.org/standard/core/LOOP +; LOOP DOadr -- L-- an an-1 .. a1 0 +LOO MOV #xloop,X +LOOPNEXT ADD #4,&DDP ; make room to compile two words + MOV &DDP,W + MOV X,-4(W) ; xloop --> HERE + MOV TOS,-2(W) ; DOadr --> HERE+2 ; resolve all "leave" adr -LEAVELOOP MOV &LEAVEPTR,TOS ; -- Adr of top LeaveStack cell - SUB #2,&LEAVEPTR ; -- - MOV @TOS,TOS ; -- first LeaveStack value - CMP #0,TOS ; -- = value left by DO ? - JZ ENDLOOPEND - MOV W,0(TOS) ; move adr after loop as UNLOOP adr - JMP LEAVELOOP -ENDLOOPEND MOV @PSP+,TOS - mNEXT - -;https://forth-standard.org/standard/core/PlusLOOP -;C +LOOP adrs -- L-- an an-1 .. a1 0 - FORTHWORDIMM "+LOOP" ; immediate -PLUSLOOP: MOV #xploop,X - JMP ENDLOOP - -;https://forth-standard.org/standard/core/LEAVE -;C LEAVE -- L: -- adrs - FORTHWORDIMM "LEAVE" ; immediate -LEAV: MOV &DDP,W ; compile three words - MOV #UNLOOP,0(W) ; [HERE] = UNLOOP - MOV #BRAN,2(W) ; [HERE+2] = BRAN - ADD #6,&DDP ; [HERE+4] = take word for AfterLOOPadr - ADD #2,&LEAVEPTR - ADD #4,W - MOV &LEAVEPTR,X - MOV W,0(X) ; leave HERE+4 on LEAVEPTR stack - mNEXT - -;https://forth-standard.org/standard/core/MOVE -;C MOVE addr1 addr2 u -- smart move -; VERSION FOR 1 ADDRESS UNIT = 1 CHAR - FORTHWORD "MOVE" -MOVE: MOV TOS,W ; 1 - MOV @PSP+,Y ; dest adrs - MOV @PSP+,X ; src adrs - MOV @PSP+,TOS ; pop new TOS - CMP #0,W - JZ MOVE_X - CMP X,Y ; Y-X ; dst - src - JZ MOVE_X ; already made ! - JC MOVEUP ; U>= if dst > src -MOVEDOWN MOV.B @X+,0(Y) ; if X=src > Y=dst copy W bytes down - ADD #1,Y - SUB #1,W - JNZ MOVEDOWN - mNEXT -MOVEUP ADD W,Y ; start at end - ADD W,X -MOVUP1 SUB #1,X - SUB #1,Y - MOV.B @X,0(Y) ; if X=src < Y=dst copy W bytes up - SUB #1,W - JNZ MOVUP1 -MOVE_X mNEXT +LEAVELOOP MOV &LEAVEPTR,TOS ; -- Adr of top LeaveStack cell + SUB #2,&LEAVEPTR ; -- + MOV @TOS,TOS ; -- first LeaveStack value + CMP #0,TOS ; -- = value left by DO ? + JZ LOOPEND + MOV W,0(TOS) ; move adr after loop as UNLOOP adr + JMP LEAVELOOP +LOOPEND MOV @PSP+,TOS + MOV @IP+,PC + FORTHWORDIMM "+LOOP" ; immediate +; https://forth-standard.org/standard/core/PlusLOOP +; +LOOP adrs -- L-- an an-1 .. a1 0 +PLUSLOOP MOV #xploop,X + JMP LOOPNEXT + .ENDIF ; CORE_COMPLEMENT + .IFDEF VOCABULARY_SET ;------------------------------------------------------------------------------- ; WORDS SET for VOCABULARY, not ANS compliant ;------------------------------------------------------------------------------- - -;X VOCABULARY -- create a vocabulary - - .IFDEF VOCABULARY_SET + .IFNDEF DOES + FORTHWORD "DOES>" +; https://forth-standard.org/standard/core/DOES +; DOES> -- set action for the latest CREATEd definition +DOES MOV &LAST_CFA,W ; W = CFA of CREATEd word + MOV #1285h,0(W) ; replace CFA (DOCON) by new CFA (DODOES) + MOV IP,2(W) ; replace PFA by the address after DOES> as execution address + MOV @RSP+,IP ; + MOV @IP+,PC ; exit of the new created word + .ENDIF FORTHWORD "VOCABULARY" -VOCABULARY: mDOCOL +;X VOCABULARY -- create a vocabulary, up to 7 vocabularies in CONTEXT +VOCABULARY mDOCOL .word CREATE - .SWITCH THREADS - .CASE 1 - .word lit,0,COMMA ; will keep the NFA of the last word of the future created vocabularies - .ELSECASE + .SWITCH THREADS + .CASE 1 + .word lit,0,COMMA ; will keep the NFA of the last word of the future created vocabularies + .ELSECASE .word lit,THREADS,lit,0,xdo VOCABULOOP .word lit,0,COMMA .word xloop,VOCABULOOP - .ENDCASE - .word HERE ; link via LASTVOC the future created vocabularies + .ENDCASE + .word HERE ; link via LASTVOC the future created vocabulary .word LIT,LASTVOC,DUP - .word FETCH,COMMA ; compile [LASTVOC] to HERE+ - .word STORE ; store (HERE - CELL) to LASTVOC - .word DOES ; compile CFA and PFA for the future defined vocabulary - + .word FETCH,COMMA ; compile [LASTVOC] to HERE+ + .word STORE ; store (HERE - 2) to LASTVOC + .word DOES ; compile CFA and PFA for the future defined vocabulary .ENDIF ; VOCABULARY_SET - VOCDOES .word LIT,CONTEXT,STORE .word EXIT -;X FORTH -- ; set FORTH the first context vocabulary; FORTH is and must be the first vocabulary .IFDEF VOCABULARY_SET FORTHWORD "FORTH" .ENDIF ; VOCABULARY_SET -FORTH: mDODOES ; leave FORTH_BODY on the stack and run VOCDOES - .word VOCDOES -FORTH_BODY .word lastforthword +;X FORTH -- ; set FORTH the first context vocabulary; FORTH must be the first vocabulary +FORTH ; leave BODYFORTH on the stack and run VOCDOES + CALL rDODOES ; Code Field Address (CFA) of FORTH +PFAFORTH .word VOCDOES ; Parameter Field Address (PFA) of FORTH +BODYFORTH ; BODY of FORTH + .word lastforthword .SWITCH THREADS .CASE 2 .word lastforthword1 @@ -2782,587 +2352,362 @@ FORTH_BODY .word lastforthword .word lastforthword29 .word lastforthword30 .word lastforthword31 + .ELSECASE + .ENDCASE + .word voclink +voclink .set $-2 + .IFDEF MSP430ASSEMBLER + .IFDEF VOCABULARY_SET + FORTHWORD "ASSEMBLER" + .ENDIF ; VOCABULARY_SET +;X ASSEMBLER -- ; set ASSEMBLER the first context vocabulary +ASSEMBLER CALL rDODOES ; leave BODYASSEMBLER on the stack and run VOCDOES + .word VOCDOES +BODYASSEMBLER + .word lastasmword + .SWITCH THREADS + .CASE 2 + .word lastasmword1 + .CASE 4 + .word lastasmword1 + .word lastasmword2 + .word lastasmword3 + .CASE 8 + .word lastasmword1 + .word lastasmword2 + .word lastasmword3 + .word lastasmword4 + .word lastasmword5 + .word lastasmword6 + .word lastasmword7 + .CASE 16 + .word lastasmword1 + .word lastasmword2 + .word lastasmword3 + .word lastasmword4 + .word lastasmword5 + .word lastasmword6 + .word lastasmword7 + .word lastasmword8 + .word lastasmword9 + .word lastasmword10 + .word lastasmword11 + .word lastasmword12 + .word lastasmword13 + .word lastasmword14 + .word lastasmword15 + .CASE 32 + .word lastasmword1 + .word lastasmword2 + .word lastasmword3 + .word lastasmword4 + .word lastasmword5 + .word lastasmword6 + .word lastasmword7 + .word lastasmword8 + .word lastasmword9 + .word lastasmword10 + .word lastasmword11 + .word lastasmword12 + .word lastasmword13 + .word lastasmword14 + .word lastasmword15 + .word lastasmword16 + .word lastasmword17 + .word lastasmword18 + .word lastasmword19 + .word lastasmword20 + .word lastasmword21 + .word lastasmword22 + .word lastasmword23 + .word lastasmword24 + .word lastasmword25 + .word lastasmword26 + .word lastasmword27 + .word lastasmword28 + .word lastasmword29 + .word lastasmword30 + .word lastasmword31 .ELSECASE .ENDCASE .word voclink voclink .set $-2 + .ENDIF ; MSP430ASSEMBLER -;X ALSO -- make room to put a vocabulary as first in context .IFDEF VOCABULARY_SET FORTHWORD "ALSO" .ENDIF ; VOCABULARY_SET -ALSO: MOV #14,W ; -- move up 7 words - MOV #CONTEXT,X ; X=src - MOV #CONTEXT+2,Y ; Y=dst - JMP MOVEUP ; src < dst +;X ALSO -- make room to put a vocabulary as first in context +ALSO MOV #12,W ; -- move up 6 words, 8th word of CONTEXT area must remain to 0 + MOV #CONTEXT+12,X ; X=src + MOV X,Y + ADD #2,Y ; Y=dst +MOVEUP SUB #1,X + SUB #1,Y + MOV.B @X,0(Y) ; if X=src < Y=dst copy W bytes beginning with the end + SUB #1,W + JNZ MOVEUP + MOV @IP+,PC -;X PREVIOUS -- pop last vocabulary out of context .IFDEF VOCABULARY_SET FORTHWORD "PREVIOUS" .ENDIF ; VOCABULARY_SET -PREVIOUS: MOV #14,W ; -- move down 7 words - MOV #CONTEXT+2,X ; X=src - MOV #CONTEXT,Y ; Y=dst - JMP MOVEDOWN ; src > dst +;X PREVIOUS -- pop last vocabulary out of context +PREVIOUS MOV #14,W ; move down 7 words, first with the 8th word equal to 0 + MOV #CONTEXT,Y ; Y=dst + MOV Y,X + ADD #2,X ; X=src +MOVEDOWN MOV.B @X+,0(Y) ; if X=src > Y=dst copy W bytes + ADD #1,Y + SUB #1,W + JNZ MOVEDOWN +MOVEND MOV @IP+,PC -;X ONLY -- cut context list to access only first vocabulary, ex.: FORTH ONLY .IFDEF VOCABULARY_SET FORTHWORD "ONLY" .ENDIF ; VOCABULARY_SET -ONLY: MOV #0,&CONTEXT+2 - mNEXT +;X ONLY -- cut context list to access only first vocabulary, ex.: FORTH ONLY +ONLY MOV #0,&CONTEXT+2 + MOV @IP+,PC -;X DEFINITIONS -- set last context vocabulary as entry for further defining words .IFDEF VOCABULARY_SET FORTHWORD "DEFINITIONS" .ENDIF ; VOCABULARY_SET -DEFINITIONS: MOV &CONTEXT,&CURRENT - mNEXT +;X DEFINITIONS -- set last context vocabulary as entry for further defining words +DEFINITIONS MOV &CONTEXT,&CURRENT + MOV @IP+,PC + + .IFDEF USE_MOVE + FORTHWORD "MOVE" +; https://forth-standard.org/standard/core/MOVE +; MOVE addr1 addr2 u -- smart move +; VERSION FOR 1 ADDRESS UNIT = 1 CHAR +MOVE MOV TOS,W ; W = cnt + MOV @PSP+,Y ; Y = addr2 = dst + MOV @PSP+,X ; X = addr1 = src + MOV @PSP+,TOS ; pop new TOS + CMP #0,W ; count = 0 ? + JZ MOVEND ; already done ! + CMP X,Y ; Y=dst = X=src ? + JZ MOVEND ; already done ! + JNC MOVEDOWN ; if Y=dst < X=src ; see PREVIOUS + ADD W,Y ; move beginning with the end + ADD W,X ; + JMP MOVEUP ; if Y=dst > X=src ; see ALSO + .ENDIF ;------------------------------------------------------------------------------- -; IMPROVED ON/OFF AND RESET +; MEMORY MANAGEMENT ;------------------------------------------------------------------------------- - -STATE_DOES - .IFDEF VOCABULARY_SET - .word FORTH,ONLY,DEFINITIONS ; doesn't restore search order pointers +STATE_DOES ; execution part of PWR_STATE ; sorry, doesn't restore search order pointers + .word FORTH,ONLY,DEFINITIONS + .word $+2 ; -- BODY IP is free + .IFDEF VOCABULARY_SET + MOV @TOS+,W ; -- BODY+2 W = old VOCLINK = VLK + .ELSE + MOV &WIPE_VOC,W ; W = VOCLINK = VLK .ENDIF - FORTHtoASM ; -- BODY IP is free - MOV @TOS+,W ; -- BODY+2 W = old VOCLINK = VLK - MOV W,&LASTVOC ; -- BODY+2 restore LASTVOC - MOV @TOS,TOS ; -- OLD_DP - MOV TOS,&DDP ; -- OLD_DP restore DP - + MOV W,&LASTVOC ; restore (or init) LASTVOC in RAM + MOV @TOS,TOS ; -- OLD_DP + MOV TOS,&DDP ; -- DP restore (or init) DP in RAM + ; then restore words link(s) with their value < old DP .SWITCH THREADS .CASE 1 ; mono thread vocabularies -MARKALLVOC MOV W,Y ; -- OLD_DP W=VLK Y=VLK -MRKWORDLOOP MOV -2(Y),Y ; -- OLD_DP W=VLK Y=NFA - CMP Y,TOS ; -- OLD_DP CMP = TOS-Y : OLD_DP-NFA - JNC MRKWORDLOOP ; loop back if TOS -RST_STATE: MOV &INIVOC,&MARKVOC ; INI value saved in FRAM - MOV &INIDP,&MARKDP ; INI value saved in FRAM + FORTHWORD "RST_STATE" ; executed by , COLD, SYSRSTIV error; does RST_HERE word set +RST_STATE MOV &RST_DP,&MARKDP ; INIT value above (FRAM value) + .IFDEF VOCABULARY_SET + MOV &RST_VOC,&MARKVOC ; INIT value above (FRAM value) + .ENDIF JMP PWR_STATE - - FORTHWORD "PWR_HERE" ; define dictionary bound for power OFF/ON -PWR_HERE: MOV &LASTVOC,&MARKVOC - MOV &DDP,&MARKDP - mNEXT - - FORTHWORD "RST_HERE" ; define dictionary bound for -RST_HERE: MOV &LASTVOC,&INIVOC - MOV &DDP,&INIDP - JMP PWR_HERE ; and init PWR_STATE same as RST_STATE - - -WIPE_DEFER MOV #PARENWARM,&WARM+2 - MOV #PARENSLEEP,&SLEEP+2 -QAB_DEFER MOV #PARENEMIT,&EMIT+2 ; always restore default console output - MOV #PARENCR,&CR+2 ; and CR to CR EMIT - MOV #PARENKEY,&KEY+2 - .IFDEF SD_CARD_LOADER - MOV #PARENACCEPT,&ACCEPT+2 ; always restore default console input + FORTHWORD "PWR_HERE" ; define word set bound for POWER_ON, ABORT_TERM. +PWR_HERE MOV &DDP,&MARKDP + .IFDEF VOCABULARY_SET + MOV &LASTVOC,&MARKVOC .ENDIF - .IFDEF MSP430ASSEMBLER ; reset all branch labels - MOV #0,&CLRBW1 - MOV #0,&CLRBW2 - MOV #0,&CLRBW3 - MOV #0,&CLRFW1 - MOV #0,&CLRFW2 - MOV #0,&CLRFW3 - .ENDIF - - RET - - FORTHWORD "WIPE" ; restore the program as it was in forthMSP430FR.txt file -WIPE: -; reset JTAG and BSL signatures ; unlock JTAG, SBW and BSL - MOV #SIGNATURES,X -SIGNLOOP MOV #-1,0(X) ; reset signature; WARNING ! DON'T CHANGE THIS IMMEDIATE VALUE ! - ADD #2,X - CMP #INTVECT,X - JNZ SIGNLOOP - -; reset all FACTORY defered words to allow execution from SD_Card - CALL #WIPE_DEFER -; reinit this factory values : - MOV #ROMDICT,&INIDP - MOV #lastvoclink,&INIVOC -; then reinit RST_STATE and PWR_STATE - JMP RST_STATE - - - -; ------------------------------------------------------------------------------------------ -; forthMSP430FR : CONDITIONNAL COMPILATION -; ------------------------------------------------------------------------------------------ - .IFDEF CONDCOMP ; 2- conditionnal compilation part - .IFNDEF LOWERCASE - .WARNING "uncomment LOWERCASE ADD-ON to pass coretest COMPARE !" - .ENDIF ; LOWERCASE - -;COMPARE ( c-addr1 u1 c-addr2 u2 -- n ) -;https://forth-standard.org/standard/string/COMPARE -;Compare the string specified by c-addr1 u1 to the string specified by c-addr2 u2. -;The strings are compared, beginning at the given addresses, character by character, -;up to the length of the shorter string or until a difference is found. -;If the two strings are identical, n is zero. -;If the two strings are identical up to the length of the shorter string, -; n is minus-one (-1) if u1 is less than u2 and one (1) otherwise. -;If the two strings are not identical up to the length of the shorter string, -; n is minus-one (-1) if the first non-matching character in the string specified by c-addr1 u1 -; has a lesser numeric value than the corresponding character in the string specified by c-addr2 u2 and one (1) otherwise. - FORTHWORD "COMPARE" -COMPARE - MOV TOS,S ;1 u2 = S - MOV @PSP+,Y ;2 addr2 = Y - MOV @PSP+,T ;2 u1 = T - MOV @PSP+,X ;2 addr1 = X -COMPAR1 MOV T,TOS ;1 - ADD S,TOS ;1 - JZ COMPEQUAL ;2 end of all successfull comparisons - SUB #1,T ;1 - JN COMPLESS ;2 u1char2 -COMPLESS ; char1name ..." -- ) -;Skipping leading spaces, parse and discard space-delimited words from the parse area, -;including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN], -;until the word [THEN] has been parsed and discarded. -;If the parse area becomes exhausted, it is refilled as with REFILL. - FORTHWORDIMM "[ELSE]" -BRACKETELSE - mDOCOL - .word lit,1 ; 1 -BRACKETELSE1 ; BEGIN -BRACKETELSE2 ; BEGIN - .word FBLANK,WORDD,COUNT ; BL WORD COUNT - .word DUP,QBRAN,BRACKETELSE10 ; DUP WHILE - .word OVER,OVER ; 2DUP - .word XSQUOTE ; S" [IF]" - .byte 4,"[IF]" ; - .word COMPARE ; COMPARE - .word QZBRAN,BRACKETELSE3 ; 0= IF - .word TWODROP,ONEPLUS ; 2DROP 1+ - .word BRAN,BRACKETELSE8 ; (ENDIF) -BRACKETELSE3 ; ELSE - .word OVER,OVER ; OVER OVER - .word XSQUOTE ; S" [ELSE]" - .byte 6,"[ELSE]" ; - .word COMPARE ; COMPARE - .word QZBRAN,BRACKETELSE5 ; 0= IF - .word TWODROP,ONEMIN ; 2DROP 1- - .word DUP,QBRAN,BRACKETELSE4 ; DUP IF - .word ONEPLUS ; 1+ -BRACKETELSE4 ; THEN - .word BRAN,BRACKETELSE7 ; (ENDIF) -BRACKETELSE5 ; ELSE - .word XSQUOTE ; S" [THEN]" - .byte 6,"[THEN]" ; - .word COMPARE ; COMPARE - .word QZBRAN,BRACKETELSE6 ; 0= IF - .word ONEMIN ; 1- -BRACKETELSE6 ; THEN -BRACKETELSE7 ; THEN -BRACKETELSE8 ; THEN - .word QDUP ; ?DUP - .word QZBRAN,BRACKETELSE9 ; 0= IF - .word EXIT ; EXIT -BRACKETELSE9 ; THEN - .word BRAN,BRACKETELSE2 ; REPEAT -BRACKETELSE10 ; - .word TWODROP ; 2DROP - .word XSQUOTE ; - .byte 3,13,107,111 ; - .word TYPE,SPACE ; CR ." ko " to show false branch of conditionnal compilation - .word TIB,DUP,CPL ; REFILL - .word ACCEPT ; -- StringOrg len' (len' <= TIB_LEN) - FORTHtoASM ; - MOV #0,&TOIN ; - MOV TOS,&SOURCE_LEN ; -- StringOrg len' - MOV @PSP+,&SOURCE_ADR ; -- len' - MOV @PSP+,TOS ; -- - MOV #BRACKETELSE1,IP ; AGAIN - mNEXT ; 78 words - - -;[IF] -;https://forth-standard.org/standard/tools/BracketIF -;Compilation: -;Perform the execution semantics given below. -;Execution: ;( flag | flag "name ..." -- ) -;If flag is true, do nothing. Otherwise, skipping leading spaces, -; parse and discard space-delimited words from the parse area, -; including nested occurrences of [IF] ... [THEN] and [IF] ... [ELSE] ... [THEN], -; until either the word [ELSE] or the word [THEN] has been parsed and discarded. -;If the parse area becomes exhausted, it is refilled as with REFILL. [IF] is an immediate word. -;An ambiguous condition exists if [IF] is POSTPONEd, -; or if the end of the input buffer is reached and cannot be refilled before the terminating [ELSE] or [THEN] is parsed. - FORTHWORDIMM "[IF]" ; flag -- - CMP #0,TOS - MOV @PSP+,TOS - JZ BRACKETELSE - mNEXT - -;[UNDEFINED] -;https://forth-standard.org/standard/tools/BracketUNDEFINED -;Compilation: -;Perform the execution semantics given below. -;Execution: ( "name ..." -- flag ) -;Skip leading space delimiters. Parse name delimited by a space. -;Return a false flag if name is the name of a word that can be found, -;otherwise return a true flag. - FORTHWORDIMM "[UNDEFINED]" - mDOCOL - .word FBLANK,WORDD,FIND,NIP,ZEROEQUAL,EXIT - -;[DEFINED] -;https://forth-standard.org/standard/tools/BracketDEFINED -;Compilation: -;Perform the execution semantics given below. -;Execution: -;( "name ..." -- flag ) -;Skip leading space delimiters. Parse name delimited by a space. -;Return a true flag if name is the name of a word that can be found, -;otherwise return a false flag. [DEFINED] is an immediate word. - - FORTHWORDIMM "[DEFINED]" - mDOCOL - .word FBLANK,WORDD,FIND,NIP,EXIT - - .ENDIF ; CONDCOMP - -; ------------------------------------------------------------------------------ -; forthMSP430FR : WARM -; ------------------------------------------------------------------------------ + MOV @IP+,PC -; define FREQ used in WARM message (6) - .IF FREQUENCY = 0.25 -FREQ .set " .2MHz" - .ELSEIF FREQUENCY = 0.5 -FREQ .set " .5MHz" - .ELSEIF FREQUENCY = 1 -FREQ .set " 1MHz" - .ELSEIF FREQUENCY = 2 -FREQ .set " 2MHz" - .ELSEIF FREQUENCY = 4 -FREQ .set " 4MHz" - .ELSEIF FREQUENCY = 8 -FREQ .set " 8MHz" - .ELSEIF FREQUENCY = 16 -FREQ .set " 16MHz" - .ELSEIF FREQUENCY = 24 -FREQ .set " 24MHz" + FORTHWORD "RST_HERE" ; define word set bound for , COLD, SYSRSTIV error. +RST_HERE MOV &DDP,&RST_DP + .IFDEF VOCABULARY_SET + MOV &LASTVOC,&RST_VOC .ENDIF - -;Z (WARM) -- ; init some user variables, - ; print start message if ECHO is set, - ; then ABORT - FORTHWORD "(WARM)" -PARENWARM: -; SUB #4,PSP -; MOV &SYSSNIV,0(PSP) -; MOV &SYSUNIV,2(PSP) - MOV &SAVE_SYSRSTIV,TOS ; to display it - mDOCOL - .word XSQUOTE ; - .byte 5,13,1Bh,"[7m" ; CR + cmd "reverse video" - .word TYPE ; - .word DOT ; display signed SAVE_SYSRSTIV -; .word DOT ; display SYSSNIV -; .word DOT ; display SYSUNIV - .word XSQUOTE - .byte 39," FastForth V162",FREQ," (C) J.M.Thoorens " - .word TYPE - .word LIT,FRAM_FULL,HERE,MINUS,UDOT - .word XSQUOTE ; - .byte 11,"bytes free "; - .word QABORTYESNOECHO ; NOECHO state enables any app to execute COLD or WARM without terminal connexion - - -;Z WARM -- ; deferred word used to init your application - ; define this word: : START ...init app here... LIT RECURSE IS WARM (WARM) ; - FORTHWORD "WARM" -WARM: MOV #PARENWARM,PC - -; ------------------------------------------------------------------------------ -; forthMSP430FR : COLD -; ------------------------------------------------------------------------------ - -;Z COLD -- performs a software reset - FORTHWORD "COLD" -COLD MOV #0A500h+PMMSWBOR,&PMMCTL0 - -;------------------------------------------------------------------------------- -; in addition to , DEEP_RST restores the program as it was in the forthMSP430FR.txt file and the electronic fuse so. -;------------------------------------------------------------------------------- + JMP PWR_HERE ; and obviously the same for POWER_ON... + +;------------------------------------------------------------------------------- +; RESET 6.2: SELECT PWR_STATE|RST_STATE|DEEP_RESET <== INI_FORTH +;------------------------------------------------------------------------------- +SEL_P_R_D CMP #0Eh,TOS ; + JZ PWR_STATE ; if RSTIV_MEM = 14 (SYSSVSH event) + CMP #4,TOS ; + JGE RST_STATE ; if RSTIV_MEM >= 4 (RESET,COLD,SYS_FAILURES) + CMP #0,TOS ; + JGE PWR_STATE ; if RSTIV_MEM >= 0 (POWER_ON,WARM,ABORT") +;-----------------------------------; +; DEEP RESET ; if RSTIV_MEM < 0 +;-----------------------------------; +; INIT SIGNATURES AREA ; +;-----------------------------------; + MOV #16,X ; max known SIGNATURES length = 12 bytes +SIGNATLOOP SUB #2,X ; + MOV #-1,SIGNATURES(X) ; reset signature; WARNING ! DON'T CHANGE IMMEDIATE VALUE ! + JNZ SIGNATLOOP ; +;-----------------------------------; X = 0 ;-) +; INIT VECTORS INT ; +;-----------------------------------; + MOV #RESET,-2(X) ; write RESET at addr X-2 = FFFEh +INIVECLOOP SUB #2,X ; + MOV #COLD,-2(X) ; -2(X) = FFFCh first + CMP #0FFAEh,X ; init 41 vectors, FFFCh down to 0FFACh + JNZ INIVECLOOP ; all vectors are initialised to execute COLD routine +;-----------------------------------; +; INIT all "CALL #xxx_APP" ; +;-----------------------------------; + MOV #WIPE_INI,X ; WIPE_INI constants are in FRAM INFO + MOV @X+,&PFACOLD ; COLD_TERM as default COLD_APP --> PFACOLD + MOV @X+,&PFA_INI_FORTH ; RET_ADR|INI_FORTH_SD as default INI_SOFT_APP --> PFA_INI_FORTH + MOV @X+,&PFASLEEP ; RXON as default BACKGND_APP --> PFASLEEP + MOV @X+,&PFAWARM ; INIT_TERM|INIT_SD as default INI_HARD_APP --> PFAWARM + MOV @X+,&TERM_VEC ; TERMINAL_INT as default vector --> TERM_VEC +;-----------------------------------; +; INIT DP VOC_link ; +;-----------------------------------; + MOV @X+,&RST_DP ; ROMDICT --> RST_DP + .IFDEF VOCABULARY_SET + MOV @X+,&RST_VOC ; lastvoclink --> RST_VOC + .ENDIF +;-----------------------------------; + JMP RST_STATE ; then return to LIT|WARM from resp. QABORT|RESET +;-----------------------------------; + +;=============================================================================== +; ┌┐ ┌─┐┬─┐ ┌─┐┌─┐┬─┐ ┌─┐┬ ┬┌─┐ ┌─┐┌─┐┬┬ ┬ ┬┬─┐┌─┐┌─┐ ┌─┐┌─┐┬ ┬ ┬ ┬┌─┐┬─┐┌─┐ +; ├┴┐│ │├┬┘ ├─┘│ │├┬┘ ├─┘│ ││ ├┤ ├─┤││ │ │├┬┘├┤ └─┐ ├┤ ├─┤│ │ ├─┤├┤ ├┬┘├┤ +; └─┘└─┘┴└─ ┴ └─┘┴└─ ┴ └─┘└─┘ └ ┴ ┴┴┴─┘└─┘┴└─└─┘└─┘ └ ┴ ┴┴─┘┴─┘ ┴ ┴└─┘┴└─└─┘ +;=============================================================================== RESET +;=============================================================================== +; RESET 1: replace pin RESET by pin NMI, stops WDT_RESET ;------------------------------------------------------------------------------- -; case 1 : Power ON ==> RESET + the volatile program beyond PWR_HERE (not protected by PWR_STATE against POWER OFF) is lost -; SYSRSTIV = 2 - -; case 2 : ==> RESET + the program beyond RST_HERE (not protected by RST_STATE against reset) is lost -; SYSRSTIV = 4 -; case 2.1 : software is performed by COLD. -; SYSRSTIV = 6 - -; case 3 : TERM_TX wired to GND via 4k7 + ===> DEEP_RST, works even if the electronic fuse is "blown" ! -; case 3.1 : (SYSRSTIV = 0Ah | SYSRSTIV >= 16h) ===> DEEP_RST on failure, -; case 3.2 : writing -1 in SAVE_SYSRSTIV then COLD ===> software DEEP_RST (WARM displays "-1") -;------------------------------------------------------------------------------- - + BIS #3,&SFRRPCR ; pin RST becomes pin NMI with falling edge, so SYSRSTIV = 4 + BIS #10h,&SFRIE1 ; enable NMI interrupt ==> hardware RESET is redirected to COLD. + MOV #5A80h,&WDTCTL ; disable WDT RESET ;------------------------------------------------------------------------------- -; RESET : Target Init, limited to FORTH usage : I/O, FRAM, RTC -; all others I/O are set as input with pullup resistor +; RESET 2: INIT STACKS ;------------------------------------------------------------------------------- - - .include "TargetInit.asm" ; include for each target the init code - -; reset all interrupt vectors to RESET vector - MOV #RESET,W ; W = reset vector - MOV #INTVECT,X ; interrupt vectors base address -RESETINT: MOV W,0(X) - ADD #2,X - JNZ RESETINT ; endloop when X = 0 - -; reset default TERMINAL vector interrupt and LPM0 mode for terminal use - MOV &INI_TERM,&TERMVEC - MOV #CPUOFF+GIE,&LPM_MODE - + MOV #RSTACK,RSP ; init return stack + MOV #PSTACK,PSP ; init parameter stack ;------------------------------------------------------------------------------- -; RESET : INIT FORTH machine +; RESET 3: init RAM to 0 ;------------------------------------------------------------------------------- - MOV #RSTACK,SP ; init return stack - MOV #PSTACK,PSP ; init parameter stack - .SWITCH DTC - .CASE 1 - MOV #xdocol,rDOCOL - .CASE 2 - MOV #EXIT,rEXIT - .CASE 3 ; inlined DOCOL, do nothing here - .ENDCASE - MOV #RFROM,rDOVAR - MOV #xdocon,rDOCON - MOV #xdodoes,rDODOES - - MOV #10,&BASE - MOV #-1,&CAPS - + MOV #RAM_LEN,X +INITRAMLOOP SUB #2,X ; 1 + MOV #0,RAM_ORG(X) ; 3 + JNZ INITRAMLOOP ; 2 6 cycles loop ! ;------------------------------------------------------------------------------- -; RESET : test TERM_TXD/Deep_RST before init TERM_UART I/O +; RESET 4: I/O, RAM, RTC, CS, SYS initialisation limited to FastForth usage. +; All unused I/O are set as input with pullup resistor. ;------------------------------------------------------------------------------- - BIC #LOCKLPM5,&PM5CTL0 ; activate all previous I/O settings before DEEP_RST test - MOV &SAVE_SYSRSTIV,Y ; - BIT.B #DEEP_RST,&Deep_RST_IN ; TERM TXD wired to GND via 4k7 resistor ? - JNZ TERM_INIT ; no - XOR #-1,Y ; yes : force DEEP_RST - ADD #1,Y ; to display SAVE_SYSRSTIV as negative value - MOV Y,&SAVE_SYSRSTIV - + .include "TargetInit.asm" ; include target specific init code ;------------------------------------------------------------------------------- -; RESET : INIT TERM_UART +; RESET 5: GET SYSRSTIV ;------------------------------------------------------------------------------- -TERM_INIT - MOV #0081h,&TERMCTLW0 ; Configure TERM_UART UCLK = SMCLK - - .include "TERMINALBAUDRATE.asm" ; include code to configure baudrate - - BIS.B #TERM_TXRX,&TERM_SEL ; Configure pins TXD & RXD for TERM_UART (PORTx_SEL0 xor PORTx_SEL1) - ; TERM_DIR is controlled by eUSCI_Ax module - BIC #UCSWRST,&TERMCTLW0 ; release from reset... - BIS #UCRXIE,&TERMIE ; ... then enable RX interrupt for wake up on terminal input - + MOV &RSTIV_MEM,TOS ; get RSTIV_MEM = Soft_SYSRSTIV + MOV #0,&RSTIV_MEM ; clear RSTIV_MEM + BIS &SYSRSTIV,TOS ; hard_SYSRSTIV|soft_SYSRSTIV --> TOS; SYSRSTIV = 0 ;------------------------------------------------------------------------------- -; RESET : Select POWER_ON||DEEP_RST +; RESET 6: START FORTH engine ;------------------------------------------------------------------------------- + CALL #INI_FORTH ; common ?ABORT|RESET "hybrid" subroutine with return to FORTH interpreter + .word WARM ; goto WARM, without return. See forthMSP430FR_TERM_xxx.asm +;-----------------------------------; -SelectReset MOV #COLD_END,IP ; define return of WIPE,RST_STATE,PWR_STATE - MOV &SAVE_SYSRSTIV,Y; - CMP #0Ah,Y ; reset event = security violation BOR ???? not documented... - JZ WIPE ; Add WIPE to this reset to do DEEP_RST -------------- - CMP #16h,Y ; reset event > software POR : failure or DEEP_RST request - JHS WIPE ; U>= ; Add WIPE to this reset to do DEEP_RST - CMP #2,Y ; reset event = Brownout ? - JNZ RST_STATE ; else execute RST_STATE - JZ PWR_STATE ; yes execute PWR_STATE - -;------------------------------------------------------------------------------- -; RESET : INIT SD_Card optionally -;------------------------------------------------------------------------------- -COLD_END - .IFNDEF SD_CARD_LOADER ; - .word WARM ; the next step - .ELSE - FORTHtoASM - BIT.B #SD_CD,&SD_CDIN ; SD_memory in SD_Card module ? - JNZ WARM ; no - .include "forthMSP430FR_SD_INIT.asm"; - JMP WARM + .IFDEF MSP430ASSEMBLER +;=============================================================================== +; ASSEMBLER OPTION +;=============================================================================== + .IFDEF EXTENDED_ASM + .include "forthMSP430FR_EXTD_ASM.asm" + .ELSE + .include "forthMSP430FR_ASM.asm" + .ENDIF .ENDIF - + .IFDEF UTILITY ;------------------------------------------------------------------------------- -; ASSEMBLER OPTION +; UTILITY WORDS OPTION ;------------------------------------------------------------------------------- - .IFDEF MSP430ASSEMBLER - .include "forthMSP430FR_ASM.asm" + .include "ADDON/UTILITY.asm" .ENDIF - + .IFDEF FIXPOINT ;------------------------------------------------------------------------------- -; UTILITY WORDS OPTION +; FIXED POINT OPERATORS OPTION ;------------------------------------------------------------------------------- - .IFDEF UTILITY - .include "ADDON\UTILITY.asm" - .ENDIF ; UTILITY - + .include "ADDON/FIXPOINT.asm" + .ENDIF .IFDEF SD_CARD_LOADER ;------------------------------------------------------------------------------- -; SD CARD FAT OPTIONS +; SD CARD OPTIONS ;------------------------------------------------------------------------------- - .include "forthMSP430FR_SD_LowLvl.asm" ; SD primitives - .include "forthMSP430FR_SD_LOAD.asm" ; SD LOAD driver + .include "forthMSP430FR_SD_LowLvl.asm" ; SD primitives + .include "forthMSP430FR_SD_INIT.asm" ; return to INIT_TERM; without use of IP,TOS + .include "forthMSP430FR_SD_LOAD.asm" ; SD LOAD driver .IFDEF SD_CARD_READ_WRITE - .include "forthMSP430FR_SD_RW.asm" ; SD Read/Write driver + .include "forthMSP430FR_SD_RW.asm" ; SD Read/Write driver .ENDIF - -;------------------------------------------------------------------------------- -; SD TOOLS + .IFDEF SD_TOOLS + .include "ADDON/SD_TOOLS.asm" + .ENDIF + .ENDIF ;------------------------------------------------------------------------------- - .IFDEF SD_TOOLS - .include "ADDON\SD_TOOLS.asm" - .ENDIF ; SD_READ_WRITE_TOOLS +; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against WIPE) +;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +; +; .include "MY_CODE.asm" +; +;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +; ADD HERE YOUR CODE TO BE INTEGRATED IN KERNEL (protected against WIPE) ;------------------------------------------------------------------------------- - .ENDIF ; SD_CARD_LOADER ;------------------------------------------------------------------------------- -; IT'S FINISH : RESOLVE ASSEMBLY PTR -;------------------------------------------------------------------------------- -ROMDICT ; init DDP with this current address -lastvoclink .equ voclink -lastforthword .equ forthlink -lastasmword .equ asmlink - - .IF THREADS <> 1 - -lastforthword1 .equ forthlink1 -lastforthword2 .equ forthlink2 -lastforthword3 .equ forthlink3 -lastforthword4 .equ forthlink4 -lastforthword5 .equ forthlink5 -lastforthword6 .equ forthlink6 -lastforthword7 .equ forthlink7 -lastforthword8 .equ forthlink8 -lastforthword9 .equ forthlink9 -lastforthword10 .equ forthlink10 -lastforthword11 .equ forthlink11 -lastforthword12 .equ forthlink12 -lastforthword13 .equ forthlink13 -lastforthword14 .equ forthlink14 -lastforthword15 .equ forthlink15 -lastforthword16 .equ forthlink16 -lastforthword17 .equ forthlink17 -lastforthword18 .equ forthlink18 -lastforthword19 .equ forthlink19 -lastforthword20 .equ forthlink20 -lastforthword21 .equ forthlink21 -lastforthword22 .equ forthlink22 -lastforthword23 .equ forthlink23 -lastforthword24 .equ forthlink24 -lastforthword25 .equ forthlink25 -lastforthword26 .equ forthlink26 -lastforthword27 .equ forthlink27 -lastforthword28 .equ forthlink28 -lastforthword29 .equ forthlink29 -lastforthword30 .equ forthlink30 -lastforthword31 .equ forthlink31 - -lastasmword1 .equ asmlink1 -lastasmword2 .equ asmlink2 -lastasmword3 .equ asmlink3 -lastasmword4 .equ asmlink4 -lastasmword5 .equ asmlink5 -lastasmword6 .equ asmlink6 -lastasmword7 .equ asmlink7 -lastasmword8 .equ asmlink8 -lastasmword9 .equ asmlink9 -lastasmword10 .equ asmlink10 -lastasmword11 .equ asmlink11 -lastasmword12 .equ asmlink12 -lastasmword13 .equ asmlink13 -lastasmword14 .equ asmlink14 -lastasmword15 .equ asmlink15 -lastasmword16 .equ asmlink16 -lastasmword17 .equ asmlink17 -lastasmword18 .equ asmlink18 -lastasmword19 .equ asmlink19 -lastasmword20 .equ asmlink20 -lastasmword21 .equ asmlink21 -lastasmword22 .equ asmlink22 -lastasmword23 .equ asmlink23 -lastasmword24 .equ asmlink24 -lastasmword25 .equ asmlink25 -lastasmword26 .equ asmlink26 -lastasmword27 .equ asmlink27 -lastasmword28 .equ asmlink28 -lastasmword29 .equ asmlink29 -lastasmword30 .equ asmlink30 -lastasmword31 .equ asmlink31 - - .ENDIF +; RESOLVE ASSEMBLY PTR, init interrupt Vectors +;------------------------------------------------------------------------------- + .include "ThingsInLast.inc"