4e-hilvl430.s43

; ------------------------------------------------------------------------------
; 4e4th is a Forth based on CamelForth 
; for the Texas Instruments MSP430 
; 
; 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 <http://www.gnu.org/licenses/>.
; 
; See LICENSE TERMS in Brads file readme.txt as well.

; ------------------------------------------------------------------------------
; 4e-hilvl430G2553.s43 - High Level Words 
; ------------------------------------------------------------------------------

; Forth words are documented as follows:
;x     NAME     stack -- stack    description
; where x=C for ANS Forth Core words, X for ANS Extensions, 
; Z for internal or private words, or submodules.
; U for user application words
; ------------------------------------------------------------------------------
; 
; 17 jan 09 bjr - changed label _DP to DDP for compatibility with token
;   naming convention.  Now uses DEST macro to compute branch offsets.
; 11 jan 09 bjr - modified QUIT for Xon/Xoff flow control
; 4 jan 09 bjr - created from Camel86h.asm.

; SYSTEM VARIABLES & CONSTANTS =================================================

;Z   U0      -- a-addr       current user area adrs
;  0 USER U0
    HEADER  U0,2,'U0',DOUSER
        DW 0

;C   >IN     -- a-addr        holds offset into TIB
;  2 USER >IN
    HEADER  TOIN,3,'>IN',DOUSER
        DW 2

;C   BASE    -- a-addr       holds conversion radix
;  4 USER BASE
    HEADER  BASE,4,'BASE',DOUSER
        DW 4

;C   STATE   -- a-addr       holds compiler state
;  6 USER STATE
    HEADER  STATE,5,'STATE',DOUSER
        DW 6

;Z   DP      -- a-addr       holds dictionary ptr
;  8 USER DP
    HEADER  DDP,2,'DP',DOUSER
        DW 8

;Z   'SOURCE  -- a-addr      two cells: len, adrs
; 10 USER 'SOURCE
    HEADER  TICKSOURCE,7,'\'SOURCE',DOUSER
        DW 10

;Z   LATEST    -- a-addr     last word in dict.
;   14 USER LATEST
    HEADER  LATEST,6,'LATEST',DOUSER
        DW 14

;Z   HP       -- a-addr     HOLD pointer
;   16 USER HP
    HEADER  HP,2,'HP',DOUSER
        DW 16

;Z   LP       -- a-addr     Leave-stack pointer
;   18 USER LP
    HEADER  LP,2,'LP',DOUSER
        DW 18

;Z   IDP    -- a-addr        ROM dictionary pointer
;   20 USER IDP
    HEADER  IDP,3,'IDP',DOUSER
        DW 20

;Z   NEWEST   -- a-addr       temporary LATEST storage
;   22 USER NEWEST
    HEADER  NEWEST,6,'NEWEST',DOUSER
        DW 22

;Z   APP      -- a-addr        app pointer ( was TURNKEY), use as APP ! To start App.
;    24 USER APP
    HEADER  APP,3,'APP',DOUSER
        DW 24

;Z   CAPS     -- a-addr        capitalize words pointer
;    26 USER CAPS
    HEADER  CAPS,4,'CAPS',DOUSER
        DW 26
        
;Z   USERKEY      -- a-addr        KEY pointer
;    28 USER KEY
    HEADER  USERKEY,7,'USERKEY',DOUSER
        DW 28

;Z   USEREMIT      -- a-addr        EMIT pointer
;    30 USER EMIT
    HEADER  USEREMIT,8,'USEREMIT',DOUSER
        DW 30

;Z   NEWLINE      -- a-addr        CR pointer
;    32 USER 
    HEADER  NEWLINE,7,'NEWLINE',DOUSER
        DW 32    

; 2 more for savety 34, 36



;X   PAD       -- a-addr    user PAD buffer = end of hold area!
    HEADER  PAD,3,'PAD',DOUSER
        DW PADAREA-UAREA

;Z   L0      -- a-addr     bottom of Leave stack
    HEADER  L0,2,'L0',DOUSER
        DW LSTACK-UAREA

;Z   R0       -- a-addr     end of return stack
    HEADER  RZERO,2,'R0',DOUSER
        DW RSTACK-UAREA

;Z   S0       -- a-addr     end of parameter stack
    HEADER  S0,2,'S0',DOUSER
        DW PSTACK-UAREA

;X   TIB     -- a-addr     Terminal Input Buffer
;  HEX 80 USER TIB       8086: above user area
    HEADER  TIB,3,'TIB',DOUSER
        DW TIBAREA-UAREA

;Z   TIBSIZE  -- n         size of TIB
    HEADER  TIBSIZE,7,'TIBSIZE',DOCON
        DW TIB_SIZE-2    ; 2 chars safety zone 

;C   BL      -- char            an ASCII space
    HEADER  BLANK,2,'BL',DOCON
        DW 20h

;Z   UINIT    -- addr       initial values for user area
    HEADER  UINIT,5,'UINIT',DOROM
uinitstart:
        DW 0,0,10,0     ; reserved,>IN,BASE,STATE  ; start in HEX  mk
        DW RAMDICT      ; DP
        DW 0,0          ; SOURCE init'd elsewhere
        DW lastword     ; LATEST
        DW 0,0          ; HP,LP init'd elsewhere
        DW USERFLASHSTART   ; IDP
        DW 0            ; NEWEST not init'd
        DW DOTCOLD      ; APP vector; default is .COLD
        DW -1           ; CAPS flag; default is TRUE
        DW DOKEY        ; KEY vector
        DW DOEMIT       ; EMIT vector
        DW DOCR         ; NEWLINE vector 
uinitend:
uareasize = uinitend-uinitstart

/******************************************************************************* 
; RAM interrupt vectors, 15 vectors of 2 cells each
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
        MOV #nullirq,PC
*******************************************************************************/

;Z   #INIT    -- n    #bytes of user area init data
    HEADER  NINIT,5,'#INIT',DOCON
        DW uareasize
        

EXTERN cor,infoB,AppU0,infoC,infoD
;Z   COR      -- adr       cause of reset
    HEADER  COR,3,'COR',DOCON
        DW cor

;Z   INFOB    -- adr       start of info B segment
    HEADER  INFOB,5,'INFOB',DOCON
        DW infoB

;Z   INFOC    -- adr       start of info C segment
    HEADER  INFOC,5,'INFOC',DOCON
        DW infoC

;Z   INFOD    -- adr       start of info C segment
    HEADER  INFOD,5,'INFOD',DOCON
        DW infoD

;Z   APPU0    -- adr       start of Application user area
    HEADER  APPU0,5,'APPU0',DOCON
        DW AppU0
        

; ARITHMETIC OPERATORS =========================================================

;C   S>D    n -- d          single -> double prec.
;   DUP 0< ;
    HEADER  STOD,3,'S>D',DOCOLON
        DW DUP,ZEROLESS,EXIT

;Z   ?NEGATE  n1 n2 -- n3  negate n1 if n2 negative
;   0< IF NEGATE THEN ;        ...a common factor
    HEADER  QNEGATE,7,'?NEGATE',DOCOLON
        DW ZEROLESS,qbran
        DEST  QNEG1
        DW NEGATE
QNEG1:  DW EXIT

;C   ABS     n1 -- +n2     absolute value
;   DUP ?NEGATE ;
    HEADER  ABBS,3,'ABS',DOCOLON
        DW DUP,QNEGATE,EXIT

;X   DNEGATE   d1 -- d2     negate double precision
;   SWAP INVERT SWAP INVERT 1 M+ ;
    HEADER  DNEGATE,7,'DNEGATE',DOCOLON
        DW SWAP,INVERT,SWAP,INVERT,lit,1,MPLUS
        DW EXIT

;Z   ?DNEGATE  d1 n -- d2   negate d1 if n negative
;   0< IF DNEGATE THEN ;       ...a common factor
    HEADER  QDNEGATE,8,'?DNEGATE',DOCOLON
        DW ZEROLESS,qbran
        DEST  DNEG1
        DW DNEGATE
DNEG1:  DW EXIT

;X   DABS     d1 -- +d2    absolute value dbl.prec.
;   DUP ?DNEGATE ;
    HEADER  DABS,4,'DABS',DOCOLON
        DW DUP,QDNEGATE,EXIT

;C   M*     n1 n2 -- d    signed 16*16->32 multiply
;   2DUP XOR >R        carries sign of the result
;   SWAP ABS SWAP ABS UM*
;   R> ?DNEGATE ;
    HEADER  MSTAR,2,'M*',DOCOLON
        DW TWODUP,XORR,TOR
        DW SWAP,ABBS,SWAP,ABBS,UMSTAR
        DW RFROM,QDNEGATE,EXIT

;C   SM/REM   d1 n1 -- n2 n3   symmetric signed div
;   2DUP XOR >R              sign of quotient
;   OVER >R                  sign of remainder
;   ABS >R DABS R> UM/MOD
;   SWAP R> ?NEGATE
;   SWAP R> ?NEGATE ;
; Ref. dpANS-6 section 3.2.2.1.
    HEADER  SMSLASHREM,6,'SM/REM',DOCOLON
        DW TWODUP,XORR,TOR,OVER,TOR
        DW ABBS,TOR,DABS,RFROM,UMSLASHMOD
        DW SWAP,RFROM,QNEGATE,SWAP,RFROM,QNEGATE
        DW EXIT

; C    d1 n1 -- n2 n3   floored signed div'n
;                            courtesy of Ed Smeda
;   DUP >R  SM/REM  2DUP  1 <  AND  IF
;     SWAP R@ +  SWAP 1-  THEN
;   R> DROP ;
; Ref. dpANS-6 section 3.2.2.1.
;    HEADER  FMSLASHMOD,6,'FM/MOD',DOCOLON
;	DW DUP,TOR,SMSLASHREM
;        DW TWODUP,lit,1,LESS,ANDD,qbran
;        DEST  FMMOD1
;        DW SWAP,RFETCH,PLUS,SWAP,ONEMINUS
;FMMOD1: DW RFROM,DROP,EXIT

; Fixed FM/MOD, added 12 nov 2012
;C   FM/MOD   d1 n1 -- n2 n3   floored signed div'n
;                            Ching-Tang Tseng  Mar 24 2012
;   DUP >R OVER OVER XOR >R 
;   SM/REM 
;   OVER R> 0< AND 
;   IF SWAP R@ + SWAP 1 - 
;   THEN R> DROP ; 
; 1 0 2 FM/MOD(OK) . . 0 1  ok 
; 7 0 9 FM/MOD(OK) . . 0 7  ok 
; Ref. dpANS-6 section 3.2.2.1.
    HEADER  FMSLASHMOD,6,'FM/MOD',DOCOLON
	DW DUP,TOR,OVER,OVER,XORR,TOR
        DW SMSLASHREM
        DW OVER,RFROM,ZEROLESS,ANDD,qbran
        DEST  FMMOD1
        DW SWAP,RFETCH,PLUS,SWAP,ONEMINUS
FMMOD1: DW RFROM,DROP,EXIT

;C   *      n1 n2 -- n3       signed multiply
;   M* DROP ;
    HEADER  STAR,1,'*',DOCOLON
        DW MSTAR,DROP,EXIT

;C   /MOD   n1 n2 -- n3 n4    signed divide/rem'dr
;   >R S>D R> FM/MOD ;
    HEADER  SLASHMOD,4,'/MOD',DOCOLON
        DW TOR,STOD,RFROM,FMSLASHMOD,EXIT

;C   /      n1 n2 -- n3       signed divide
;   /MOD nip ;
    HEADER  SLASH,1,'/',DOCOLON
        DW SLASHMOD,NIP,EXIT

;C   MOD    n1 n2 -- n3       signed remainder
;   /MOD DROP ;
    HEADER  MODD,3,'MOD',DOCOLON
        DW SLASHMOD,DROP,EXIT

;C   */MOD  n1 n2 n3 -- n4 n5    n1*n2/n3, rem&quot
;   >R M* R> FM/MOD ;
    HEADER  SSMOD,5,'*/MOD',DOCOLON
        DW TOR,MSTAR,RFROM,FMSLASHMOD,EXIT

;C   */     n1 n2 n3 -- n4        n1*n2/n3
;   */MOD nip ;
    HEADER  STARSLASH,2,'*/',DOCOLON
        DW SSMOD,NIP,EXIT

;C   MAX    n1 n2 -- n3       signed maximum
;   2DUP < IF SWAP THEN DROP ;
    HEADER  MAX,3,'MAX',DOCOLON
        DW TWODUP,LESS,qbran
        DEST  MAX1
        DW  SWAP
MAX1:   DW DROP,EXIT

;C   MIN    n1 n2 -- n3       signed minimum
;   2DUP > IF SWAP THEN DROP ;
    HEADER  MIN,3,'MIN',DOCOLON
        DW TWODUP,GREATER,qbran
        DEST  MIN1
        DW SWAP
MIN1:   DW DROP,EXIT

; DOUBLE OPERATORS =============================================================

;C   2@    a-addr -- x1 x2    fetch 2 cells
;   DUP CELL+ @ SWAP @ ;
;   the lower address will appear on top of stack
    HEADER  TWOFETCH,2,'2@',DOCOLON
        DW DUP,CELLPLUS,FETCH,SWAP,FETCH,EXIT

;C   2!    x1 x2 a-addr --    store 2 cells
;   SWAP OVER ! CELL+ ! ;
;   the top of stack is stored at the lower adrs
    HEADER  TWOSTORE,2,'2!',DOCOLON
        DW SWAP,OVER,STORE,CELLPLUS,STORE,EXIT

;C   2DROP  x1 x2 --          drop 2 cells
;   DROP DROP ;
    HEADER  TWODROP,5,'2DROP',DOCOLON
        DW DROP,DROP,EXIT

;C   2DUP   x1 x2 -- x1 x2 x1 x2            dup top 2 cells
;   OVER OVER ;
    HEADER  TWODUP,4,'2DUP',DOCOLON
        DW OVER,OVER,EXIT

;C   2SWAP  x1 x2 x3 x4 -- x3 x4 x1 x2       per diagram
;   ROT >R ROT R> ;
    HEADER  TWOSWAP,5,'2SWAP',DOCOLON
        DW ROT,TOR,ROT,RFROM,EXIT

;C   2OVER  x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2     per diagram
;   >R >R 2DUP R> R> 2SWAP ;
    HEADER  TWOOVER,5,'2OVER',DOCOLON
        DW TOR,TOR,TWODUP,RFROM,RFROM
        DW TWOSWAP,EXIT

; INPUT/OUTPUT =================================================================

PUBLIC DOCR

;C   COUNT   c-addr1 -- c-addr2 u        counted->adr/len
;   DUP CHAR+ SWAP C@ ;
    HEADER  COUNT,5,'COUNT',DOCOLON
        DW DUP,CHARPLUS,SWAP,CFETCH,EXIT

;C   DOCR      --               output newline 
;   0D EMIT 0A EMIT ;
    HEADER  DOCR,4,'DOCR',DOCOLON
        DW lit,0dh,EMIT,lit,0ah,EMIT,EXIT

;C   CR      --               output newline
; userkey @ execute ;
    HEADER  CR,2,'CR',DOCOLON
        DW NEWLINE,FETCH,EXECUTE,EXIT

;C   SPACE   --               output a space
;   BL EMIT ;
    HEADER  SPACE,5,'SPACE',DOCOLON
        DW BLANK,EMIT,EXIT

;C   SPACES   n --            output n spaces
;   BEGIN DUP WHILE SPACE 1- REPEAT DROP ;
    HEADER  SPACES,6,'SPACES',DOCOLON
SPCS1:  DW DUP,qbran
        DEST  SPCS2
        DW SPACE,ONEMINUS,bran
        DEST  SPCS1
SPCS2:  DW DROP,EXIT

;Z   UMIN     u1 u2 -- u      unsigned minimum
;   2DUP U> IF SWAP THEN DROP ;
    HEADER  UMIN,4,'UMIN',DOCOLON
        DW TWODUP,UGREATER,qbran
        DEST  UMIN1
        DW SWAP
UMIN1:  DW DROP,EXIT

;Z   UMAX    u1 u2 -- u       unsigned maximum
;   2DUP U< IF SWAP THEN DROP ;
    HEADER  UMAX,4,'UMAX',DOCOLON
        DW TWODUP,ULESS,qbran
        DEST  UMAX1
        DW SWAP
UMAX1:  DW DROP,EXIT

; C .ERR#  n --            print error number
    HEADER DOTERRN,5,'.ERR#',DOCOLON
        DW lit,15H,EMIT  ; emit a NAK ($15)
        DW lit,3FH,EMIT
        DW BASE,FETCH,TOR,DECIMAL
        DW DOT
        DW RFROM,BASE,STORE
        DW EXIT

; C ?TIB  adr1 adr2 --            error if line too long
    HEADERLESS QTIB,4,'?TIB',DOCOLON
        DW GREATER,qbran
        DEST QTIB1
        DW lit,406,DOTERRN
        DW CR,ABORT
QTIB1:  DW EXIT

;C   ACCEPT  c-addr +n -- +n'       get line from term'l
;   OVER + 1- OVER      -- sa ea a
;   BEGIN KEY           -- sa ea a c
;   DUP 0D <> WHILE
;       DUP EMIT        -- sa ea a c
;       DUP 8 = IF  DROP 1-    >R OVER R> UMAX
;             ELSE  OVER C! 1+ OVER UMIN
;       THEN            -- sa ea a
;   REPEAT              -- sa ea a c
;   DROP NIP SWAP - ;
    HEADER  ACCEPT,6,'ACCEPT',DOCOLON
        DW OVER,PLUS,ONEMINUS,OVER
ACC1: ;  DW KEY,DUP,lit,0DH,NOTEQUAL,qbran
        DW KEY
        DW DUP,lit,0DH,NOTEQUAL ; ( -- c f ) CR
;        DW OVER,lit,0AH,NOTEQUAL ; ( -- c f f ) LF
;        DW ANDD
        DW qbran
        DEST  ACC5
        DW DUP,EMIT
;        DW DUP,STORELEDS ; testing
        DW DUP,lit,8,EQUAL,qbran  ;mk BS received?
        DEST  ACC3
        DW DROP,ONEMINUS,TOR,OVER,RFROM,UMAX ;mk backspace handling
        DW SPACE,lit,8,EMIT ;mk $08 == BS (for tera term and hyterterminal)
        DW bran
        DEST  ACC4
;       ( -- sa ea a c )
ACC3:   DW OVER,CSTORE,ONEPLUS
;       ( -- sa ea a+1 )
;        DW OVER,UMIN  ; einfacher zähler stillstand
        DW TWODUP,SWAP,QTIB ; line too long?
ACC4:   DW bran
        DEST  ACC1
ACC5:   DW DROP,NIP,SWAP,MINUS,EXIT

;C   TYPE    c-addr +n --     type line to term'l
;   ?DUP IF
;     OVER + SWAP DO I C@ EMIT LOOP
;   ELSE DROP THEN ;
    HEADER  TYP,4,'TYPE',DOCOLON
        DW QDUP,qbran
        DEST  TYP4
        DW OVER,PLUS,SWAP,xdo
TYP3:   DW II,CFETCH,EMIT,xloop
        DEST  TYP3
        DW bran
        DEST  TYP5
TYP4:   DW DROP
TYP5:   DW EXIT

#define ITYPE TYP
#define ICOUNT COUNT

/* ; HARVARD MODEL EXTENSIONS (split Code & Data)

; Z ICOUNT  c-addr1 -- c-addr2 u  counted->adr/len
;   DUP CHAR+ SWAP IC@ ;          from Code space
    HEADER  ICOUNT,6,'ICOUNT',DOCOLON
        DW DUP,CHARPLUS,SWAP,ICFETCH,EXIT

; Z ITYPE   c-addr +n --       type line to term'l
;   ?DUP IF                       from Code space
;     OVER + SWAP DO I IC@ EMIT LOOP
;   ELSE DROP THEN ;
    HEADER  ITYPE,5,'ITYPE',DOCOLON
        DW QDUP,qbran
        DEST  ITYP4
        DW OVER,PLUS,SWAP,xdo
ITYP3:  DW II,ICFETCH,EMIT,xloop
        DEST  ITYP3
        DW bran
        DEST  ITYP5
ITYP4:  DW DROP
ITYP5:  DW EXIT
*/


;Z   (IS")     -- c-addr u   run-time code for S"
;   R> ICOUNT 2DUP + ALIGNED >R  ;
; Harvard model, for string stored in Code space
; e.g. as used by ."
    HEADER  XISQUOTE,5,'(IS")',DOCOLON
        DW RFROM,ICOUNT,TWODUP,PLUS,ALIGNED,TOR
        DW EXIT

;Z   (S")     -- c-addr u         run-time code for S"
;   R@ I@                     get Data address
;   R> CELL+ DUP IC@ CHAR+    -- Dadr Radr+2 n+1
;   2DUP + ALIGNED >R         -- Dadr Iadr n+1
;   >R OVER R> I->D           -- Dadr
;   COUNT ;
; Harvard model, for string stored in Code space
; which is copied to Data space.
    HEADER  XSQUOTE,4,'(S")',DOCOLON
        DW RFETCH,IFETCH
        DW RFROM,CELLPLUS,DUP,ICFETCH,CHARPLUS
        DW TWODUP,PLUS,ALIGNED,TOR
        DW TOR,OVER,RFROM,ITOD,COUNT,EXIT

;Z   IS"      --            compile in-line string
;   COMPILE (IS")  [ HEX ]
;   22 PARSE     ( -- c-addr n ) 
;   DUP >R IC,  IHERE R@ D->I
;   R> IALLOT ALIGN ; IMMEDIATE
; Harvard model: string is stored in Code space
    IMMED  ISQUOTE,3,'IS"',DOCOLON
        DW lit,XISQUOTE,COMMAXT
        DW lit,22H,PARSE
        DW DUP,TOR,ICCOMMA,IHERE,RFETCH,DTOI
        DW RFROM,IALLOT,ALIGNN,EXIT

;Z   IS"      --            compile in-line string  OLD DEF'N
;   COMPILE (IS")  [ HEX ]
;   22 IWORD
;   IC@ 1+ ALIGNED IALLOT ; IMMEDIATE
; Harvard model: string is stored in Code space
;   IMMED  ISQUOTE,3,'IS"',DOCOLON
;       DW lit,XISQUOTE,COMMAXT
;       DW lit,22H,IWORD
;       DW ICFETCH,ONEPLUS,ALIGNED,IALLOT,EXIT

;C   S"       --             compile in-line string
;   COMPILE (S")  [ HEX ]
;   HERE I,                     data address
;   22 PARSE     ( -- c-addr n ) 
;   DUP >R IC,  IHERE R@ D->I
;   R@ 1+ ALLOT                 reserve RAM space
;   R> IALLOT ALIGN ; IMMEDIATE
; Harvard model: string is stored in Code space
    IMMED  SQUOTE,2,'S"',DOCOLON
        DW lit,XSQUOTE,COMMAXT
        DW HERE,ICOMMA,lit,22H,PARSE
        DW DUP,TOR,ICCOMMA,IHERE,RFETCH,DTOI
        DW RFETCH,ONEPLUS,ALLOT
        DW RFROM,IALLOT,ALIGNN,EXIT

;C   S"       --             compile in-line string  OLD DEF'N
;   COMPILE (S")  [ HEX ]
;   HERE I,                     data address
;   22 IWORD
;   IC@ 1+ ALIGNED
;   DUP ALLOT IALLOT ; IMMEDIATE
; Harvard model: string is stored in Code space
;    IMMED  SQUOTE,2,'S"',DOCOLON
;        DW lit,XSQUOTE,COMMAXT
;        DW HERE,ICOMMA,lit,22H,IWORD
;        DW ICFETCH,ONEPLUS,ALIGNED
;        DW DUP,ALLOT,IALLOT,EXIT

;C   ."       --         compile string to print
;   POSTPONE IS"  POSTPONE ITYPE ; IMMEDIATE
    IMMED  DOTQUOTE,2,'."',DOCOLON
        DW ISQUOTE
        DW lit,ITYPE,COMMAXT
        DW EXIT

;Z   IWORD     c -- c-addr       WORD to Code space
;   WORD
;   IHERE TUCK OVER C@ CHAR+ D->I ;
    HEADER  IWORD,5,'IWORD',DOCOLON
        DW WORDD
IWORD1: DW IHERE,TUCK,OVER,CFETCH
        DW CHARPLUS,DTOI,EXIT

;Z   IWORDC     c -- c-addr       maybe capitalize WORD to Code space
;   WORD CAPITALIZE
;   IHERE TUCK OVER C@ CHAR+ D->I ;
;    HEADER  IWORDC,6,'IWORDC',DOCOLON
     HEADLESS IWORDC, DOCOLON
        DW WORDD, CAPITALIZE
        DW bran
        DEST IWORD1

; SEPARATE HEADER EXTENSIONS ARE NOT USED
#define HCOUNT ICOUNT
#define HTYPE  ITYPE
#define HWORD  IWORDC

; NUMERIC OUTPUT ===============================================================
; Numeric conversion is done l.s.digit first, so
; the output buffer is built backwards in memory.

; Some double-precision arithmetic operators are
; needed to implement ANSI numeric conversion.

;Z   UD/MOD   ud1 u2 -- u3 ud4       32/16->32 divide
;   >R 0 R@ UM/MOD  ROT ROT R> UM/MOD ROT ;
    HEADER  UDSLASHMOD,6,'UD/MOD',DOCOLON
        DW TOR,ZERO,RFETCH,UMSLASHMOD,ROT,ROT
        DW RFROM,UMSLASHMOD,ROT,EXIT

;Z   UD*      ud1 d2 -- ud3          32*16->32 multiply
;   DUP >R UM* DROP  SWAP R> UM* ROT + ;
    HEADER  UDSTAR,3,'UD*',DOCOLON
        DW DUP,TOR,UMSTAR,DROP
        DW SWAP,RFROM,UMSTAR,ROT,PLUS,EXIT

;C   HOLD  char --        add char to output string
;   -1 HP +!  HP @ C! ;
    HEADER  HOLD,4,'HOLD',DOCOLON
        DW lit,-1,HP,PLUSSTORE
        DW HP,FETCH,CSTORE,EXIT

;C   <#    --             begin numeric conversion
;   PAD HP ! ;          (initialize Hold Pointer)
    HEADER  LESSNUM,2,'<#',DOCOLON
        DW PAD,HP,STORE,EXIT

;Z   >digit   n -- c      convert to 0..9A..Z
;   [ HEX ] DUP 9 > 7 AND + 30 + ;
    HEADER  TODIGIT,6,'>DIGIT',DOCOLON
        DW DUP,lit,9,GREATER,lit,7,ANDD,PLUS
        DW lit,30H,PLUS,EXIT

;C   #     ud1 -- ud2     convert 1 digit of output
;   BASE @ UD/MOD ROT >digit HOLD ;
    HEADER  NUM,1,'#',DOCOLON
        DW BASE,FETCH,UDSLASHMOD,ROT,TODIGIT
        DW HOLD,EXIT

;C   #S    ud1 -- ud2     convert remaining digits
;   BEGIN # 2DUP OR 0= UNTIL ;
    HEADER  NUMS,2,'#S',DOCOLON
NUMS1:  DW NUM,TWODUP,ORR,ZEROEQUAL,qbran
        DEST  NUMS1
        DW EXIT

;C   #>    ud1 -- c-addr u       end conv., get string
;   2DROP HP @ PAD OVER - ;
    HEADER  NUMGREATER,2,'#>',DOCOLON
        DW TWODROP,HP,FETCH,PAD,OVER,MINUS,EXIT

;C   SIGN  n --           add minus sign if n<0
;   0< IF 2D HOLD THEN ;
    HEADER  SIGN,4,'SIGN',DOCOLON
        DW ZEROLESS,qbran
        DEST  SIGN1
        DW lit,2DH,HOLD
SIGN1:  DW EXIT

;C   U.    u --           display u unsigned
;   <# 0 #S #> TYPE SPACE ;
    HEADER  UDOT,2,'U.',DOCOLON
        DW LESSNUM,ZERO,NUMS,NUMGREATER,TYP
        DW SPACE,EXIT

;C   .     n --           display n signed
;   <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ;
    HEADER  DOT,1,'.',DOCOLON
        DW LESSNUM,DUP,ABBS,ZERO,NUMS
        DW ROT,SIGN,NUMGREATER,TYP,SPACE,EXIT

;C   DECIMAL  --      set number base to decimal
;   10 BASE ! ;
    HEADER  DECIMAL,7,'DECIMAL',DOCOLON
        DW lit,10,BASE,STORE,EXIT

;X   HEX     --       set number base to hex
;   16 BASE ! ;
    HEADER  HEX,3,'HEX',DOCOLON
        DW lit,16,BASE,STORE,EXIT

; DICTIONARY MANAGEMENT ========================================================

;C   HERE    -- addr      returns dictionary ptr
;   DP @ ;
    HEADER  HERE,4,'HERE',DOCOLON
        DW DDP,FETCH,EXIT

;C   ALLOT   n --         allocate n bytes in dict
;   DP +! ;
    HEADER  ALLOT,5,'ALLOT',DOCOLON
        DW DDP,PLUSSTORE,EXIT

;C   ,    x --           append cell to dict
;   HERE ! 1 CELLS ALLOT ;
    HEADER  COMMA,1,',',DOCOLON
        DW HERE,STORE,lit,1,CELLS,ALLOT,EXIT

;C   C,   char --        append char to dict
;   HERE C! 1 CHARS ALLOT ;
    HEADER  CCOMMA,2,'C,',DOCOLON
        DW HERE,CSTORE,lit,1,CHARS,ALLOT,EXIT

; The following additional words support the
; "Harvard" model, with separate address spaces
; for Instructions (Code) and Data.  ANSI
; requires DP to manage the Data space, so a
; separate Instruction Dictionary Pointer, IDP,
; is added to manage the Code space.  Also added:
;   I@ IC@ I! IC! I->D D->I   (in the primitives)
;   ITYPE ICOUNT IWORD        (above)
;   IHERE IALLOT I, IC,       (below)
; It should be possible to convert the Harvard
; implementation to a combined-code-and-data
; system, by equating these words to their
; Data-space counterparts.

; on MSP430 we have Neumann, but
;    I! IC! D->I   (in the primitives) work on flash
;    I@ IC@ alias @ C@
;    I->D alias CMOVE
;    IWORD works on flash
;    IHERE IALLOT I, IC,  work on flash

;C   IHERE    -- addr       returns Code dictionary ptr
;   IDP @ ;
    HEADER  IHERE,5,'IHERE',DOCOLON
        DW IDP,FETCH,EXIT

;C   IALLOT   n --          allocate n bytes in Code dict
;   IDP +! ;
    HEADER  IALLOT,6,'IALLOT',DOCOLON
        DW IDP,PLUSSTORE,EXIT

;C   I,    x --           append cell to Code dict
;   IHERE I! 1 CELLS IALLOT ;
    HEADER  ICOMMA,2,'I,',DOCOLON
        DW IHERE,ISTORE,lit,1,CELLS,IALLOT,EXIT

;C   IC,   char --        append char to Code dict
;   IHERE IC! 1 CHARS IALLOT ;
    HEADER  ICCOMMA,3,'IC,',DOCOLON
        DW IHERE,ICSTORE,lit,1,CHARS,IALLOT,EXIT

; SEPARATE HEADER EXTENSIONS ARE NOT USED
#define HHERE IHERE
#define HALLOT IALLOT
#define HCOMMA ICOMMA
#define HCCOMMA ICCOMMA
#define HCFETCH ICFETCH
#define HFETCH IFETCH
#define HCSTORE ICSTORE
#define HSTORE ISTORE

; INTERPRETER ==================================================================
; Note that NFA>LFA, NFA>CFA, IMMED?, and FIND
; are dependent on the structure of the Forth
; header.  This may be common across many CPUs,
; or it may be different.

; ?STACK   --               check stack underflow
; depth 0< abort" SUF" ;  
   HEADER  QSTACK,6,'?STACK',DOCOLON
        DW DEPTH,ZEROLESS,XISQUOTE
        DB 3,'SUF'
        DW QABORT,EXIT

;C   SOURCE   -- adr n    current input buffer
;   'SOURCE 2@ ;        length is at lower adrs
    HEADER  SOURCE,6,'SOURCE',DOCOLON
        DW TICKSOURCE,TWOFETCH,EXIT

;X   /STRING  a u n -- a+n u-n   trim string
;   ROT OVER + ROT ROT - ;
    HEADER  SLASHSTRING,7,'/STRING',DOCOLON
        DW ROT,OVER,PLUS,ROT,ROT,MINUS,EXIT

;Z   >counted  src n dst --     copy to counted str
;   2DUP C! CHAR+ SWAP CMOVE ;
    HEADER  TOCOUNTED,8,'>COUNTED',DOCOLON
        DW TWODUP,CSTORE,CHARPLUS,SWAP,CMOVE,EXIT

;Z   ADR>IN   c-addr' --    set >IN to offset to given adr
;   SOURCE         -- adr' adr n
;   ROT ROT -      -- n adr'-adr
;   MIN  0 MAX     -- n'
;   >IN ! ;
    HEADER  ADRTOIN,6,'ADR>IN',DOCOLON
        DW SOURCE,ROT,ROT,MINUS,MIN,lit,0,MAX
        DW TOIN,STORE,EXIT

;X   PARSE   char -- c-addr n    word delim'd by char
;   SOURCE >IN @ /STRING        -- c adr n
;   OVER >R                     save adr of string start
;   ROT SCAN                    -- adr" n"
;   OVER SWAP IF CHAR+ THEN    skip trailing delim. if any
;   ADR>IN                     advance >IN   -- adr"
;   R> TUCK - ;                 -- adr n'
    HEADER PARSE,5,'PARSE',DOCOLON
        DW SOURCE,TOIN,FETCH,SLASHSTRING
        DW OVER,TOR,ROT,SCAN
        DW OVER,SWAP,qbran
        DEST PARSE1
        DW ONEPLUS  ; char+
PARSE1: DW ADRTOIN
        DW RFROM,TUCK,MINUS,EXIT

;C   WORD   char -- c-addr    word delim'd by char
;   DUP  SOURCE >IN @ /STRING   -- c c adr n
;   ROT SKIP                    -- c adr' n'
;   DROP ADR>IN PARSE           -- adr" n"
;   HERE >counted               --
;   HERE                        -- a
;   BL OVER COUNT + C! ;    append trailing blank
    HEADER  WORDD,4,'WORD',DOCOLON
        DW DUP,SOURCE,TOIN,FETCH,SLASHSTRING
        DW ROT,SKIP
        DW DROP,ADRTOIN,PARSE
        DW HERE,TOCOUNTED,HERE
        DW BLANK,OVER,COUNT,PLUS,CSTORE,EXIT
    
;C   WORD   char -- c-addr    word delim'd by char  OLD DEF'N
;   DUP  SOURCE >IN @ /STRING   -- c c adr n
;   DUP >R   ROT SKIP           -- c adr' n'
;   OVER >R  ROT SCAN           -- adr" n"
;   DUP IF CHAR- THEN        skip trailing delim.
;   R> R> ROT -   >IN +!        update >IN offset
;   TUCK -                      -- adr' N
;   HERE >counted               --
;   HERE                        -- a
;   BL OVER COUNT + C! ;    append trailing blank
;    HEADER  WORDD,4,'WORD',DOCOLON
;        DW DUP,SOURCE,TOIN,FETCH,SLASHSTRING
;        DW DUP,TOR,ROT,SKIP
;        DW OVER,TOR,ROT,SCAN
;        DW DUP,qbran
;        DEST  WORD1
;        DW ONEMINUS  ; char-
;WORD1:  DW RFROM,RFROM,ROT,MINUS,TOIN,PLUSSTORE
;        DW TUCK,MINUS
;        DW HERE,TOCOUNTED,HERE
;        DW BLANK,OVER,COUNT,PLUS,CSTORE,EXIT

;Z   NFA>LFA   nfa -- lfa      name adr -> link field
;   3 - ;
    HEADER  NFATOLFA,7,'NFA>LFA',DOCOLON
        DW lit,3,MINUS,EXIT

;Z   NFA>CFA   nfa -- cfa      name adr -> code field
;   HCOUNT 7F AND + ALIGNED ;   mask off 'smudge' bit
    HEADER  NFATOCFA,7,'NFA>CFA',DOCOLON
        DW HCOUNT
        DW lit,07FH,ANDD,PLUS,ALIGNED,EXIT

;Z   IMMED?    nfa -- f        fetch immediate flag
;   1- HC@ 1 AND 0= ;   Flashable model, LSB=0 if immed
    HEADER  IMMEDQ,6,'IMMED?',DOCOLON
        DW ONEMINUS,HCFETCH,lit,1,ANDD,ZEROEQUAL,EXIT

;C   FIND   c-addr -- c-addr 0   if not found
;C   FIND   c-addr -- xt 1c      if immediate
;C   FIND   c-addr -- xt -1      if "normal"
;   LATEST @ BEGIN             -- a nfa
;       2DUP OVER C@ CHAR+     -- a nfa a nfa n+1
;       N=                     -- a nfa f
;       DUP IF
;           DROP
;           NFA>LFA H@ DUP     -- a link link
;       THEN
;   0= UNTIL                   -- a nfa  OR  a 0
;   DUP IF
;       NIP DUP NFA>CFA        -- nfa xt
;       SWAP IMMED?            -- xt iflag
;       0= 1 OR                -- xt 1/-1
;   THEN ;
    HEADER  FIND,4,'FIND',DOCOLON
        DW LATEST,FETCH
FIND1:  DW TWODUP,OVER,CFETCH,CHARPLUS
        DW NEQUAL,DUP,qbran
        DEST  FIND2
        DW DROP,NFATOLFA,HFETCH,DUP
FIND2:  DW ZEROEQUAL,qbran
        DEST  FIND1
        DW DUP,qbran
        DEST  FIND3
        DW NIP,DUP,NFATOCFA
        DW SWAP,IMMEDQ,ZEROEQUAL,lit,1,ORR
FIND3:  DW EXIT

;C   UPC   char -- char        capitalize character
; DUP [CHAR] a < OVER [CHAR] z > OR IF EXIT THEN  
; [ CHAR A CHAR a - ] LITERAL + ; 
;  HEADER  UPC,3,'UPC',DOCOLON
    HEADLESS UPC, DOCOLON
        DW DUP, lit, 'a', LESS, OVER, lit, 'z', GREATER
        DW ORR, qbran
        DEST  UPC1
        DW EXIT
UPC1:   DW lit, 'A'-'a', PLUS
        DW EXIT

;C   CAPITALIZE     c-addr -- c-addr     capitalize string
;
; CAPS @ IF DUP COUNT OVER + SWAP ?DO  I c@ upc I c! LOOP THEN
;   HEADER CAPITALIZE, 10, 'CAPITALIZE', DOCOLON
    HEADLESS CAPITALIZE, DOCOLON
        DW CAPS, FETCH, qbran
        DEST CAPS2
        DW DUP, COUNT, OVER, PLUS, SWAP, xdo
CAPS1:  DW II, CFETCH, UPC, II, CSTORE
        DW xloop
        DEST CAPS1
CAPS2:  DW EXIT

;C   LITERAL  x --        append numeric literal
;   STATE @ IF ['] LIT ,XT I, THEN ; IMMEDIATE
; This tests STATE so that it can also be used
; interpretively.  (ANSI doesn't require this.)
    IMMED  LITERAL,7,'LITERAL',DOCOLON
        DW STATE,FETCH,qbran
        DEST  LITER1
        DW lit,lit,COMMAXT,ICOMMA
LITER1: DW EXIT

;Z   DIGIT?   c -- n -1 | x 0     if c is a valid digit | otherwise
;   [ HEX ] DUP 39 > 100 AND +     silly looking
;   DUP 140 > 107 AND -   30 -     but it works!
;   DUP BASE @ U< ;
    HEADER  DIGITQ,6,'DIGIT?',DOCOLON
        DW DUP,lit,39H,GREATER,lit,100H,ANDD,PLUS
        DW DUP,lit,140H,GREATER,lit,107H,ANDD
        DW MINUS,lit,30H,MINUS
        DW DUP,BASE,FETCH,ULESS,EXIT

;Z   ?SIGN      adr n -- adr' n' f    get optional sign; advance adr/n if sign; return NZ if negative
;   OVER C@                 -- adr n c
;   2C - DUP ABS 1 = AND    -- +=-1, -=+1, else 0
;   DUP IF 1+               -- +=0, -=+2
;       >R 1 /STRING R>     -- adr' n' f
;   THEN ;
    HEADER  QSIGN,5,'?SIGN',DOCOLON
        DW OVER,CFETCH,lit,2CH,MINUS,DUP,ABBS
        DW lit,1,EQUAL,ANDD,DUP,qbran
        DEST  QSIGN1
        DW ONEPLUS,TOR,lit,1,SLASHSTRING,RFROM
QSIGN1: DW EXIT

;C   >NUMBER  ud adr u -- ud' adr' u'       convert string to number
;   BEGIN
;   DUP WHILE
;       OVER C@ DIGIT?
;       0= IF DROP EXIT THEN
;       >R 2SWAP BASE @ UD*
;       R> M+ 2SWAP
;       1 /STRING
;   REPEAT ;
    HEADER  TONUMBER,7,'>NUMBER',DOCOLON
TONUM1: DW DUP,qbran
        DEST  TONUM3
        DW OVER,CFETCH,DIGITQ
        DW ZEROEQUAL,qbran
        DEST  TONUM2
        DW DROP,EXIT
TONUM2: DW TOR,TWOSWAP,BASE,FETCH,UDSTAR
        DW RFROM,MPLUS,TWOSWAP
        DW lit,1,SLASHSTRING,bran
        DEST  TONUM1
TONUM3: DW EXIT

;Z   ?NUMBER  c-addr -- n -1        string->number
;Z   ?NUMBER  c-addr -- c-addr 0    if convert error
;   DUP  0 0 ROT COUNT      -- ca ud adr n
;   ?SIGN >R  >NUMBER       -- ca ud adr' n'
;   IF   R> 2DROP 2DROP 0   -- ca 0   (error)
;   ELSE 2DROP NIP R>
;       IF NEGATE THEN  -1  -- n -1   (ok)
;   THEN ;
    HEADER  QNUMBER,7,'?NUMBER',DOCOLON
        DW DUP,ZERO,DUP,ROT,COUNT
        DW QSIGN,TOR,TONUMBER,qbran
        DEST  QNUM1
        DW RFROM,TWODROP,TWODROP,lit,0
        DW bran
        DEST  QNUM3
QNUM1:  DW TWODROP,NIP,RFROM,qbran
        DEST  QNUM2
        DW NEGATE
QNUM2:  DW lit,-1
QNUM3:  DW EXIT

;Z   INTERPRET    i*x c-addr u -- j*x                 interpret given buffer
; This is a common factor of EVALUATE and QUIT.
; ref. dpANS-6, 3.4 The Forth Text Interpreter
;   'SOURCE 2!  0 >IN !
;   BEGIN
;   BL WORD DUP C@ WHILE        -- textadr
;       CAPITALIZE
;       FIND                    -- a 0/1/-1
;       ?DUP IF                 -- xt 1/-1
;           1+ STATE @ 0= OR    IMMED  or interp?
;           IF EXECUTE ELSE ,XT THEN
;       ELSE                    -- textadr
;           ?NUMBER
;           IF POSTPONE LITERAL     converted ok
;           ELSE COUNT TYPE 3F EMIT CR ABORT  err
;           THEN
;       THEN
;   REPEAT DROP ;
    HEADER  INTERPRET,9,'INTERPRET',DOCOLON
        DW TICKSOURCE,TWOSTORE,ZERO,TOIN,STORE
INTER1: DW QSTACK ; ?stack prüft auf stck underflow  mk
        DW BLANK,WORDD,DUP,CFETCH,qbran
        DEST  INTER9
        DW CAPITALIZE
        DW FIND,QDUP,qbran
        DEST  INTER4
        DW ONEPLUS,STATE,FETCH,ZEROEQUAL,ORR
        DW qbran
        DEST  INTER2
        DW EXECUTE,bran
        DEST  INTER3
INTER2: DW COMMAXT
INTER3: DW bran
        DEST  INTER8
INTER4: DW QNUMBER,qbran
        DEST  INTER5
        DW LITERAL,bran
        DEST  INTER6
INTER5: DW COUNT,TYP
        DW lit,15H,EMIT  ; emit a NAK ($15)
        DW lit,3FH,EMIT
;        DW TOIN,FETCH,DOT
        DW CR,ABORT
INTER6:
INTER8: DW bran
        DEST  INTER1
INTER9: DW DROP,EXIT

;C   EVALUATE  i*x c-addr u -- j*x              interprt string
;   'SOURCE 2@ >R >R  >IN @ >R
;   INTERPRET
;   R> >IN !  R> R> 'SOURCE 2! ;
    HEADER  EVALUATE,8,'EVALUATE',DOCOLON
        DW TICKSOURCE,TWOFETCH,TOR,TOR
        DW TOIN,FETCH,TOR,INTERPRET
        DW RFROM,TOIN,STORE,RFROM,RFROM
        DW TICKSOURCE,TWOSTORE,EXIT

#define PREFIXPROMPT 0

; C DOTSTATUS  --           display system status
   HEADLESS DOTSTATUS,DOCOLON
         DW lit,11H,EMIT  ; send XON
         DW CR
         IF PREFIXPROMPT=1
           DW XISQUOTE
           DB 3,'OK '    ; for prefix prompt style
           DW ITYPE
         ENDIF
         DW EXIT   

; C PROMPT  --            prompt user
    HEADLESS PROMPT,DOCOLON
        IF PREFIXPROMPT!=1
          DW STATE,FETCH,ZEROEQUAL,qbran
          DEST PROMPT1
          DW lit,06H,EMIT ; send ACK
          DW BASE,FETCH,DUP,HEX,lit,'$',EMIT,lit,02,ZEROUDOTR,BASE,STORE
          DW XISQUOTE
          DB 3,'ok '    ; for traditional Forth style
          DW ITYPE
        ENDIF
PROMPT1:DW EXIT


;C   QUIT     -- R: i*x --     interpret from kbd
;   L0 LP !  R0 RP!   0 STATE !
;   BEGIN
;       xon EMIT
;       TIB DUP TIBSIZE ACCEPT
;       xoff EMIT  SPACE
;       INTERPRET
;       CR STATE @ 0= IF ." OK" THEN
;   AGAIN ;
    HEADER  QUIT,4,'QUIT',DOCOLON
        DW L0,LP,STORE
        DW RZERO,RPSTORE,ZERO,STATE,STORE
QUIT1:  DW DOTSTATUS
        DW TIB,DUP,TIBSIZE,ACCEPT
        ; DW lit,13H,EMIT         ; send XOFF
        DW SPACE
        DW INTERPRET
	DW PROMPT
        DW bran
        DEST  QUIT1
PUBLIC QUITIP
QUITIP  equ QUIT+2
        
;C   ABORT    i*x -- R: j*x --    clear stk & QUIT
;   S0 SP!  QUIT ;
    HEADER  ABORT,5,'ABORT',DOCOLON
abort1  DW S0,SPSTORE,QUIT   ; QUIT never returns

;Z   ?ABORT   f c-addr u --      abort & print msg
;   ROT IF ITYPE ABORT THEN 2DROP ;
    HEADER  QABORT,6,'?ABORT',DOCOLON
        DW ROT,qbran
        DEST  QABO1
        DW ITYPE,ABORT
QABO1:  DW TWODROP,EXIT

;C   ABORT"   i*x 0 -- i*x R: j*x -- j*x      x1=0
;C   ABORT"   i*x x1 -- R: j*x --             x1<>0
;   POSTPONE IS" POSTPONE ?ABORT ; IMMEDIATE
    IMMED  ABORTQUOTE,6,'ABORT"',DOCOLON
        DW ISQUOTE
        DW lit,QABORT,COMMAXT
        DW EXIT

;C   '    -- xt           find word in dictionary
;   BL WORD CAPITALIZE FIND
;   0= ABORT" ?" ;
    HEADER  TICK,1,27h,DOCOLON
        DW BLANK,WORDD,CAPITALIZE,FIND,ZEROEQUAL,XISQUOTE
        DB 1,'?'
        DW QABORT,EXIT

;C   CHAR   -- char           parse ASCII character
;   BL WORD 1+ C@ ;
    HEADER  CHARR,4,'CHAR',DOCOLON
        DW BLANK,WORDD,ONEPLUS,CFETCH,EXIT

;C   [CHAR]   --          compile character literal
;   CHAR  ['] LIT ,XT  I, ; IMMEDIATE
    IMMED  BRACCHAR,6,'[CHAR]',DOCOLON
        DW CHARR
        DW lit,lit,COMMAXT
        DW ICOMMA,EXIT

;C   (    --                     skip input until )
;   [ HEX ] 29 PARSE 2DROP ; IMMEDIATE
    IMMED  PAREN,1,'(',DOCOLON
        DW lit,29H,PARSE,TWODROP,EXIT

; COMPILER =====================================================================

;Z   HEADER   --      create a Forth word header
;   LATEST @ H, 0FF HC,         link & IMMED  field
;   HHERE LATEST !            new "latest" link
;   BL HWORD HC@ 1+ HALLOT    name field
;   ALIGN ;
; Separate headers model.
    HEADER  HEADR,6,'HEADER',DOCOLON
        DW LATEST,FETCH,HCOMMA      ; link
        DW lit,0FFh,HCCOMMA         ; immediate flag - see note below
        DW HHERE,LATEST,STORE
        DW BLANK,HWORD,HCFETCH,ONEPLUS,HALLOT
        DW ALIGNN,EXIT   ; MSP430: headers in I space must be aligned
; Note for Flashable MSP430: when compiling to RAM, we need to set
; the immediate byte to 0FFH.  When compiling to Flash, the word IC!
; will not write 0FFH to erased Flash (because the byte is already 0FFH).
; Thus we can write this byte at a later time (with IMMEDIATE).

;Z   <BUILDS  --      define a word with t.b.d. action & no data
;   HEADER 2 IALLOT ;       Flashable: do not store Code Field
    HEADER  BUILDS,7,'<BUILDS',DOCOLON
        DW HEADR,lit,2,IALLOT,EXIT

;C   CREATE   --      create an empty definition pointing to RAM
;   HEADER
;   docreate ,CF              code field
;   HERE I, ;           store data adr (Harvard)
; Harvard model, separate Code and Data spaces.
; Separate headers model.
    HEADER  CREATE,6,'CREATE',DOCOLON
        DW HEADR
        DW lit,docreate,COMMACF
        DW HERE,ICOMMA,EXIT

;Z   (DOES>)  --      run-time action of DOES>
;   R>              adrs of headless DOES> def'n
;   LATEST @ NFA>CFA    code field to fix up
;   !CF ;
    HEADER  XDOES,7,'(DOES>)',DOCOLON
        DW RFROM,LATEST,FETCH,NFATOCFA,STORECF
        DW EXIT

;C   DOES>    --      change action of latest def'n
;   COMPILE (DOES>)
;   dodoes ,JMP ; IMMEDIATE
; Note that MSP430 uses a JMP, not a CALL, to DODOES.
    IMMED  DOES,5,'DOES>',DOCOLON
        DW lit,XDOES,COMMAXT
        DW lit,dodoes,COMMAJMP,EXIT

;C   RECURSE  --      recurse current definition
;   LATEST @ NFA>CFA ,XT ; IMMEDIATE
;   NEWEST @ NFA>CFA ,XT ; IMMEDIATE   Flashable
    IMMED  RECURSE,7,'RECURSE',DOCOLON
        DW NEWEST,FETCH,NFATOCFA,COMMAXT,EXIT

;C   [        --      enter interpretive state
;   0 STATE ! ; IMMEDIATE
    IMMED  LEFTBRACKET,1,'[',DOCOLON
        DW ZERO,STATE,STORE,EXIT

;C   ]        --      enter compiling state
;   -1 STATE ! ;
    HEADER  RIGHTBRACKET,1,']',DOCOLON
        DW lit,-1,STATE,STORE,EXIT

;Z   HIDE     --      "hide" latest definition    Flashable
;   LATEST @ DUP NEWEST !  NFA>LFA H@ LATEST ! ;
    HEADER  HIDE,4,'HIDE',DOCOLON
        DW LATEST,FETCH,DUP,NEWEST,STORE
        DW NFATOLFA,HFETCH,LATEST,STORE,EXIT

;Z   REVEAL   --      "reveal" latest definition  Flashable
;   NEWEST @ LATEST ! ;
    HEADER  REVEAL,6,'REVEAL',DOCOLON
        DW NEWEST,FETCH,LATEST,STORE,EXIT

;C   IMMEDIATE   --   make last def'n immediate
;   0FE LATEST @ 1- HC! ;   set Flashable immediate flag
    HEADER  IMMEDIATE,9,'IMMEDIATE',DOCOLON
        DW lit,0FEh,LATEST,FETCH,ONEMINUS,HCSTORE
        DW EXIT

;C   :        --      begin a colon definition  
;   <BUILDS HIDE ] !COLON ;      Flashable version
    HEADER  COLON,1,':',DOCOLON
        DW BUILDS,HIDE,RIGHTBRACKET,STORCOLON
        DW EXIT

;C   ;       --       end a colon definition 
;   REVEAL  ,EXIT
;   POSTPONE [  ; IMMEDIATE
    IMMED  SEMICOLON,1,';',DOCOLON
        DW REVEAL,CEXIT
        DW LEFTBRACKET,EXIT

;C   [']  --         find word & compile as literal
;   '  ['] LIT ,XT  I, ; IMMEDIATE
; When encountered in a colon definition, the
; phrase  ['] xxx  will cause   LIT,xxt  to be
; compiled into the colon definition (where
; (where xxt is the execution token of word xxx).
; When the colon definition executes, xxt will
; be put on the stack.  (All xt's are one cell.)
    IMMED  BRACTICK,3,'[\']',DOCOLON
        DW TICK               ; get xt of 'xxx'
        DW lit,lit,COMMAXT    ; append LIT action
        DW ICOMMA,EXIT        ; append xt literal

;C   POSTPONE  --   postpone compile action of word
;   BL WORD FIND
;   DUP 0= ABORT" ?"
;   0< IF   -- xt  non immed: add code to current
;                  def'n to compile xt later.
;       ['] LIT ,XT  I,     add "LIT,xt,COMMAXT"
;       ['] ,XT ,XT         to current definition
;   ELSE  ,XT      immed: compile into cur. def'n
;   THEN ; IMMEDIATE
    IMMED  POSTPONE,8,'POSTPONE',DOCOLON
        DW BLANK,WORDD,FIND,DUP,ZEROEQUAL,XISQUOTE
        DB 1,'?'
        DW QABORT,ZEROLESS,qbran
        DEST  POST1
        DW lit,lit,COMMAXT,ICOMMA
        DW lit,COMMAXT,COMMAXT,bran
        DEST  POST2
POST1:  DW COMMAXT
POST2:  DW EXIT

;Z   COMPILE   --   append inline execution token
;   R> DUP CELL+ >R @ ,XT ;
; The phrase ['] xxx ,XT appears so often that
; this word was created to combine the actions
; of LIT and ,XT.  It takes an inline literal
; execution token and appends it to the dict.
;    HEADER  COMPILE,7,'COMPILE',DOCOLON
;        DW RFROM,DUP,CELLPLUS,TOR
;        DW FETCH,COMMAXT,EXIT
; N.B.: not used in the current implementation

; CONTROL STRUCTURES ===========================================================

;C   IF       -- adrs      conditional forward branch
;   ['] qbran ,BRANCH  IHERE ,NONE ;      Flashable
;   IMMEDIATE
    IMMED  IFF,2,'IF',DOCOLON
        DW lit,qbran,COMMABRANCH
        DW IHERE,COMMANONE,EXIT

;C   THEN     adrs --        resolve forward branch
;   IHERE SWAP !DEST ; IMMEDIATE
    IMMED  THEN,4,'THEN',DOCOLON
        DW IHERE,SWAP,STOREDEST,EXIT

;C   ELSE     adrs1 -- adrs2    branch for IF..ELSE
;   ['] branch ,BRANCH  IHERE ,NONE       Flashable
;   SWAP  POSTPONE THEN ; IMMEDIATE
    IMMED  ELSS,4,'ELSE',DOCOLON
        DW lit,bran,COMMABRANCH
        DW IHERE,COMMANONE
        DW SWAP,THEN,EXIT

;C   BEGIN    -- adrs        target for bwd. branch
;   IHERE ; IMMEDIATE
    IMMED  BEGIN,5,'BEGIN',DOCOLON
        DW IHERE,EXIT

;C   UNTIL    adrs --   conditional backward branch
;   ['] qbran ,BRANCH  ,DEST ; IMMEDIATE
;   conditional backward branch
    IMMED  UNTIL,5,'UNTIL',DOCOLON
        DW lit,qbran,COMMABRANCH
        DW COMMADEST,EXIT

;X   AGAIN    adrs --      uncond'l backward branch
;   ['] branch ,BRANCH  ,DEST ; IMMEDIATE
;   unconditional backward branch
    IMMED  AGAIN,5,'AGAIN',DOCOLON
        DW lit,bran,COMMABRANCH
        DW COMMADEST,EXIT

;C   WHILE    adrs1 -- adrs2 adrs1           branch for WHILE loop
;   POSTPONE IF SWAP ; IMMEDIATE
    IMMED  WHILE,5,'WHILE',DOCOLON
        DW IFF,SWAP,EXIT

;C   REPEAT   adrs2 adrs1 --            resolve WHILE loop
;   POSTPONE AGAIN POSTPONE THEN ; IMMEDIATE
    IMMED  REPEAT,6,'REPEAT',DOCOLON
        DW AGAIN,THEN,EXIT

;Z   >L   x -- L: -- x        move to leave stack
;   CELL LP +!  LP @ ! ;      (L stack grows up)
    HEADER  TOL,2,'>L',DOCOLON
        DW CELL,LP,PLUSSTORE,LP,FETCH,STORE,EXIT

;Z   L>   -- x L: x --      move from leave stack
;   LP @ @  CELL NEGATE LP +! ;
    HEADER  LFROM,2,'L>',DOCOLON
        DW LP,FETCH,FETCH
        DW CELL,NEGATE,LP,PLUSSTORE,EXIT

;C   DO       -- adrs L: -- 0       start a loop 
;   ['] xdo ,XT   IHERE     target for bwd branch
;   0 >L ; IMMEDIATE           marker for LEAVEs
    IMMED  DO,2,'DO',DOCOLON
        DW lit,xdo,COMMAXT,IHERE
        DW ZERO,TOL,EXIT

;Z   ENDLOOP   adrs xt -- L: 0 a1 a2 .. aN --    common factor of LOOP and +LOOP
;   ,BRANCH  ,DEST                backward loop
;   BEGIN L> ?DUP WHILE POSTPONE THEN REPEAT ;
;                                 resolve LEAVEs
; This is a common factor of LOOP and +LOOP.
    HEADER  ENDLOOP,7,'ENDLOOP',DOCOLON
        DW COMMABRANCH,COMMADEST
LOOP1:  DW LFROM,QDUP,qbran
        DEST  LOOP2
        DW THEN,bran
        DEST  LOOP1
LOOP2:  DW EXIT

;C   LOOP    adrs -- L: 0 a1 a2 .. aN --    finish a loop
;   ['] xloop ENDLOOP ;  IMMEDIATE
    IMMED  LOO,4,'LOOP',DOCOLON
        DW lit,xloop,ENDLOOP,EXIT

;C   +LOOP   adrs -- L: 0 a1 a2 .. aN --    finish a loop
;   ['] xplusloop ENDLOOP ;  IMMEDIATE
    IMMED  PLUSLOOP,5,'+LOOP',DOCOLON
        DW lit,xplusloop,ENDLOOP,EXIT

;C   LEAVE    -- L: -- adrs                 leave a loop
;   ['] UNLOOP ,XT
;   ['] branch ,BRANCH   IHERE ,NONE  >L
;   ; IMMEDIATE      unconditional forward branch
    IMMED  LEAV,5,'LEAVE',DOCOLON
        DW lit,UNLOOP,COMMAXT
        DW lit,bran,COMMABRANCH
        DW IHERE,COMMANONE,TOL,EXIT

; OTHER OPERATIONS =============================================================

;X   WITHIN    n1|u1 n2|u2 n3|u3 -- f          n2<=n1<n3?
;  OVER - >R - R> U< ;          per ANS document
    HEADER  WITHIN,6,'WITHIN',DOCOLON
        DW OVER,MINUS,TOR,MINUS,RFROM,ULESS,EXIT

;C   MOVE    addr1 addr2 u --     smart move
;             VERSION FOR 1 ADDRESS UNIT = 1 CHAR
;  >R 2DUP SWAP DUP R@ +     -- ... dst src src+n
;  WITHIN IF  R> CMOVE>        src <= dst < src+n
;       ELSE  R> CMOVE  THEN ;          otherwise
    HEADER  MOVE,4,'MOVE',DOCOLON
        DW TOR,TWODUP,SWAP,DUP,RFETCH,PLUS
        DW WITHIN,qbran
        DEST  MOVE1
        DW RFROM,CMOVEUP,bran
        DEST  MOVE2
MOVE1:  DW RFROM,CMOVE
MOVE2:  DW EXIT

;C   DEPTH    -- +n        number of items on stack
;   SP@ S0 SWAP - 2/ ;   16-BIT VERSION!
    HEADER  DEPTH,5,'DEPTH',DOCOLON
        DW SPFETCH,S0,SWAP,MINUS,TWOSLASH,EXIT

;C   ENVIRONMENT?  c-addr u -- false | i*x true      system query
;   2DROP 0 ;       the minimal definition!
    HEADER  ENVIRONMENTQ,12,'ENVIRONMENT?',DOCOLON
        DW TWODROP,ZERO,EXIT

; UTILITY WORDS ================================================================

;Z   NOOP       --    do nothing
    HEADER  NOOP,4,'NOOP',DOCOLON
      DW EXIT

;Z   FLALIGNED   a -- a'      align IDP to flash boundary
;   $200 OVER - $1FF AND + ;
    HEADER  FLALIGNED,9,'FLALIGNED',DOCOLON
        DW lit,0200h,OVER,MINUS,lit,01FFh,ANDD,PLUS,EXIT

;X   MARKER   --      create word to restore dictionary
;   LATEST @ IHERE HERE
;   IHERE FLALIGNED IDP !     align new word to flash boundary
;   <BUILDS I, I, I,        save dp,idp,latest
;   DOES>  DUP I@  
;   SWAP CELL+ DUP I@
;   SWAP CELL+ I@           fetch saved   -- dp idp latest 
;   OVER FLALIGNED IHERE OVER - FLERASE    erase Flash from saved to IHERE
;   LATEST ! IDP ! DP ! ;
    HEADER  MARKER,6,'MARKER',DOCOLON
        DW LATEST,FETCH,IHERE,HERE
        DW IHERE,FLALIGNED,IDP,STORE
        DW BUILDS,ICOMMA,ICOMMA,ICOMMA,XDOES
        MOV #dodoes,PC      ; long direct jump to DODOES
        DW DUP,IFETCH
        DW SWAP,CELLPLUS,DUP,IFETCH
        DW SWAP,CELLPLUS,IFETCH
        DW OVER,FLALIGNED,IHERE,OVER,MINUS,FLERASE
        DW LATEST,STORE,IDP,STORE,DDP,STORE,EXIT

/***
; X WORDS    --          list all words in dict.
;   LATEST @ BEGIN
;       DUP HCOUNT 7F AND HTYPE SPACE
;       NFA>LFA H@
;   DUP 0= UNTIL
;   DROP ;
    HEADER  WORDS,5,'WORDS',DOCOLON
        DW LATEST,FETCH
WDS1:   DW DUP,HCOUNT,lit,07FH,ANDD,HTYPE,SPACE
        DW NFATOLFA,HFETCH
        DW DUP,ZEROEQUAL,qbran
        DEST  WDS1
        DW DROP,EXIT
***/        
       
;X   WORDS    --          list all words in dict. Stop and go key version.
;   LATEST @ BEGIN
;       KEY? IF KEY DROP KEY 0x0D = IF DROP EXIT THEN THEN  
;       DUP HCOUNT 7F AND HTYPE SPACE
;       NFA>LFA H@
;   DUP 0= UNTIL
;   DROP ;
    HEADER  WORDS,5,'WORDS',DOCOLON
        DW LATEST,FETCH
WDS1:   DW KEYQ,qbran
        DEST WDS2
        DW KEY,DROP ; halt
        DW KEY,BLANK,EQUAL,qbran ; go on if blank, else quit words
        DEST WDS3
WDS2:   DW DUP,HCOUNT,lit,07FH,ANDD,HTYPE,SPACE
        DW NFATOLFA,HFETCH
        DW DUP,ZEROEQUAL,qbran
        DEST  WDS1
WDS3:   DW DROP,EXIT

;X   (U.R)    u n -- xxx          display u unsigned in n width; primitiv
;   >R  <# 0 #S #>  R> OVER - 0 MAX  (jump) ;
    HEADLESS  PARENUDOTR,DOCOLON
        DW TOR,LESSNUM,ZERO,NUMS,NUMGREATER
        DW RFROM,OVER,MINUS,ZERO,MAX
        DW EXIT
        
;X   U.R    u n --           display u unsigned in n width
;   >R  <# 0 #S #>  R> OVER - 0 MAX SPACES  TYPE ;
    HEADER  UDOTR,3,'U.R',DOCOLON
        DW PARENUDOTR
        DW SPACES,TYP,EXIT
        
;X   0U.R    u n --           display u unsigned in n width with leading zeros
;   >R  <# 0 #S #>  R> OVER - 0 MAX SPACES  TYPE ;
    HEADER  ZEROUDOTR,4,'0U.R',DOCOLON
        DW PARENUDOTR
        DW ZEROS,TYP,EXIT

;X   ZEROS   n --            output n zeros
;   BEGIN DUP WHILE ZERO 1- REPEAT DROP ;
    HEADER  ZEROS,5,'ZEROS',DOCOLON
ZEROS1:  DW DUP,qbran
        DEST  ZEROS2
        DW lit,'0',EMIT,ONEMINUS,bran
        DEST  ZEROS1
ZEROS2:  DW DROP,EXIT



;X   DUMP  adr n --         dump memory
;  OVER + SWAP DO
;    CR I 4 U.R SPACE SPACE
;    I $10 + I DO I C@ 3 U.R LOOP  SPACE SPACE
;    I $10 + I DO I C@ $7F AND $7E MIN BL MAX EMIT LOOP
;  10 +LOOP ;
    HEADER  DUMP,4,'DUMP',DOCOLON
        DW OVER,PLUS,SWAP,xdo
LDUMP1: DW CR,II,lit,4,UDOTR,SPACE,SPACE
        DW II,lit,10h,PLUS,II,xdo
LDUMP2: DW II,CFETCH,lit,3,UDOTR,xloop
        DEST  LDUMP2
        DW SPACE,SPACE
        DW II,lit,10h,PLUS,II,xdo
LDUMP3: DW II,CFETCH,lit,7Fh,ANDD,lit,7Eh,MIN,BLANK,MAX,EMIT,xloop
        DEST  LDUMP3
        DW lit,10h,xplusloop
        DEST  LDUMP1
        DW EXIT

;X   .S      --           print stack contents
;   [char] < EMIT   DEPTH . BS [char] > EMIT  
;   SP@ S0 < IF
;       SP@ S0 2 - DO I @ U. -2 +LOOP
;   THEN ;
    HEADER  DOTS,2,'.S',DOCOLON
        ;mk gforth style 
        DW lit,$3C,EMIT
        DW DEPTH,DOT
        DW lit,$08,EMIT,lit,$3E,EMIT,SPACE 
        ;/mk
        DW SPFETCH,S0,LESS,qbran
        DEST  DOTS2
        DW SPFETCH,S0,lit,2,MINUS
;        DW TWODUP,TOR,TOR,
        DW xdo
DOTS1:  DW II,FETCH,DOT,lit,-2,xplusloop
;DOTS1:  DW II,FETCH,UDOT,lit,-2,xplusloop
        DEST  DOTS1
;        DW lit,'|',EMIT,RFROM,RFROM
;        DW xdo
;DOTS11: DW II,FETCH,UDOT,lit,-2,xplusloop
;        DEST  DOTS11
DOTS2:  DW EXIT


; U CCRC      n c -- n'     crc process byte
;   8 LSHIFT XOR
;   8 0 DO ( n' )
;     DUP 1 LSHIFT  SWAP 8000 AND 0= INVERT 1021 ( CRC-16 )  AND  XOR 
;   LOOP 
;   FFFF AND ;
;   HEADER  CCRC,4,'CCRC',DOCODE
    HEADLESS CCRC,DOCODE
          AND #00FFh,TOS
          SWPB TOS
          XOR @PSP+,TOS
          MOV #8,W
   ccrc1: RLA TOS
          JNC ccrc2
          XOR #01021h,TOS
   ccrc2: DEC W
          JNZ ccrc1
          NEXT

;Z   CRC     n addr len -- n'     crc process string
;   dup IF over + swap DO  ( n ) I C@ ccrc LOOP ELSE 2drop THEN ;
    HEADER  CRC,3,'CRC',DOCOLON
          DW DUP,qbran
          DEST pcrc2
          DW OVER,PLUS,SWAP,xdo
pcrc1:    DW II,CFETCH,CCRC, xloop
          DEST pcrc1
          DW bran
          DEST pcrc3
pcrc2:    DW TWODROP
pcrc3:	  DW EXIT



; MISC =========================================================================

;C   2CONSTANT    <name> w1 w2 --    define a Forth double constant
;   <BUILDS  I, I,           Flashable Harvard model
;   DOES> (machine code fragment)
; Note that the constant is stored in Code space.
        HEADER TWOCONSTANT,9,'2CONSTANT',DOCOLON
        DW BUILDS,ICOMMA,ICOMMA,XDOES
        PUBLIC DOTWOCON
DOTWOCON:  ; ( -- w1 w2 )
      SUB #4,PSP       ; make room on stack
      MOV TOS,2(PSP)
      MOV @W+,TOS      ; fetch from parameter field to TOS
      MOV @W,0(PSP)    ; fetch secon word from parameter field to NOS
      NEXT

;U   \         --      backslash 
; everything up to the end of the current line is a comment. 
;   SOURCE >IN ! DROP ; 
    IMMED BACKSLASH,1,'\\',DOCOLON
        DW SOURCE,TOIN,STORE,DROP,EXIT 

;Z   .VER     --     type message   
        HEADER  DOTVER,4,'.VER',DOCOLON      
        DW lit,version,COUNT,ITYPE ; # of version 
        DW lit,stamp,COUNT,ONEMINUS,ITYPE ; time stamp of version
        ;DW DOTBOOTVERSION
        DW SPACE
        ;DW BASE,FETCH,BIN
        ;DW COR,FETCH,lit,16,ZEROUDOTR ; flags indicating reset procedure. 
        ;DW BASE,STORE
        DW EXIT 

;U   BELL     --                send $07 to Terminal
     HEADER BELL,4,'BELL',DOCOLON
         DW lit,7,EMIT,EXIT

;Z   ESC[     --                start esc-sequence
; 27 emit 91 emit ;
     HEADERLESS  ESCPAR,4,'ESC[',DOCOLON
         DW lit,27,EMIT, lit,91,EMIT
         DW EXIT

;Z   PN      --                 send parameter of esc-sequence
; base @  swap decimal 0 u.r  base ! ; 
     HEADERLESS  PN,2,'PN',DOCOLON
         DW BASE,FETCH
         DW SWAP,DECIMAL,ZERO,UDOTR
         DW BASE,STORE
         DW EXIT

;Z   ;PN    --                  send delimiter ; followed by parameter
; 59 emit pn ;
     HEADERLESS SEMIPN,3,';PN',DOCOLON
         DW lit,59,EMIT,PN
         DW EXIT

;U   AT-XY   x y --          set cursor position in terminal
; 1+ swap 1+ swap ESC[ pn ;pn 72 emit ; 
     HEADER ATXY,5,'AT-XY',DOCOLON
         DW ONEPLUS,SWAP,ONEPLUS,SWAP
         DW ESCPAR,PN
         DW SEMIPN, lit,72,EMIT
         DW EXIT

;U   PAGE    --              send "page" command to terminal to clear screen.
; esc[  ." 2J" 0 0 at-xy ;
     HEADER PAGEE,4,'PAGE',DOCOLON
        DW ESCPAR
        DW XISQUOTE
        DB (ESC1-ESC0)
ESC0:   DB '2J'
        EVEN
ESC1:   DW ITYPE
        DW ZERO,ZERO,ATXY
        DW EXIT

;U   BIN   --                set number base to binary
     HEADER BIN,3,'BIN',DOCOLON
         DW lit,2,BASE,STORE,EXIT
         
; ommitted, MSP430G2553 RAM is too smal.
;U   RAM   --                compile into RAM. SAVE your system befor using RAM.
; here  unused 10 - allot  idp ! ; Use COLD to swich back to flash.
;     HEADER RAM,3,'RAM',DOCOLON
;         DW HERE,UNUSED,lit,0x10,MINUS,ALLOT,IDP,STORE,EXIT

;U   TRUE   -- f            true flag
    HEADER  TRUE,4,'TRUE',DOCON
        DW 0xFFFF

;U   FALSE   -- f            false flag
    HEADER  FALSE,5,'FALSE',DOCON
        DW 0x0
        
;C   TABLE   --      create an empty definition pointing to FLASH
;   HEADER
;   docreate ,CF              code field
;   IHERE I, ;           store data adr (Harvard)
; Harvard model, separate Code and Data spaces.
; Separate headers model.
; or do this (4e4th):
;  : TABLE  <builds ihere cell + i, does> @ ;
   HEADER  TABLE,5,'TABLE',DOCOLON
        DW HEADR
        DW lit,docreate,COMMACF
        DW IHERE,CELL,PLUS,ICOMMA,EXIT



; MCU specific words ===========================================================

/*
; .ID      -- <string>          Print MCU identifier.
        HEADER  DOTID,3,'.ID',DOCOLON      
        DW lit,id,COUNT,ITYPE 
        DW EXIT  
*/

;U   1MS     --                    wait about 1 millisecond
;  xx 0 DO yy 0 DO LOOP LOOP ;  adjust xx and yy to get a msec.
     HEADER ONEMS,3,'1MS',DOCOLON
         DW lit,41,ZERO,xdo 
onems1:  DW lit,11,ZERO,xdo
onems2:  DW xloop
         DEST onems2
         DW xloop
         DEST onems1
         DW EXIT

;U   MS       n --                wait about n milliseconds
;  0 DO 1MS LOOP ;
     HEADER MS,2,'MS',DOCOLON
         DW ZERO,xdo
ms1:     DW ONEMS,xloop
         DEST ms1
         DW EXIT


; Bits -------------------------------------------------------------------------
;  based on http://www.forth.org/svfig/Len/bits.htm

;U   SET    mask addr --      set bit from mask in addr (cell); use even adr!
    HEADER  wset,3,'SET',DOCODE
      BIS     @PSP,0(TOS)
      ADD     #2,PSP
      MOV     @PSP+,TOS
      NEXT

;U   CSET    mask addr --      set bit from mask in addr (byte)
    HEADER  cset,4,'CSET',DOCODE
      BIS.B   @PSP,0(TOS)
      ADD     #2,PSP
      MOV     @PSP+,TOS
      NEXT

;U   CLR     mask addr --      reset bit from mask in addr (cell); use even adr!
    HEADER  wclr,3,'CLR',DOCODE
      BIC     @PSP,0(TOS)
      ADD     #2,PSP
      MOV     @PSP+,TOS
      NEXT

;U   CCLR    mask addr --      reset bit from mask in addr (byte)
    HEADER  cclr,4,'CCLR',DOCODE
      BIC.B   @PSP,0(TOS)
      ADD     #2,PSP
      MOV     @PSP+,TOS
      NEXT

;U   CTOGGLE    mask addr --        flip bit from mask in addr (byte)
    HEADER  ctoggle,7,'CTOGGLE',DOCODE
      XOR.B   @PSP,0(TOS)
      ADD     #2,PSP
      MOV     @PSP+,TOS
      NEXT

;U   CGET       mask addr -- flag    test bit from mask in addr (byte)
    HEADER  cget,4,'CGET',DOCODE
      BIT.B   @PSP,0(TOS)
      JZ cget1
      MOV #-1,TOS
      JMP cget2
cget1:MOV #0, TOS
cget2:ADD     #2,PSP
      NEXT


; Memory info ------------------------------------------------------------------

/* see also: XLINK configuration file for MSP430G2553 
ram   =: 0200-03FF
    0200-03C9    forth system; userarea, stacks, tib, pad ...
    03CA-03FF    VARAREA for forth variables; check UNUSED ram.

flash =: C000-FFFF
    C000-D7FF   MEMBOT to MEMTOP is user flash. Check unsused MEM.  
    D800-FDFF   kernel
    FE00-FFFF   INTSEG
    FFE0-FFFF   INTVEC
    FFFE-FFFF   RESET
*/

;Z   RESETADR   -- adr      reset vector address
;    HEADER  RESETADR,8,'RESETADR',DOCON
;        DW resetvec

;Z   MEMBOT   -- adr       begining of USERflash         
    HEADER  MEMBOT,6,'MEMBOT',DOCON
        DW USERFLASHSTART 

;Z   MEMTOP   -- adr       end of USERflash         
    HEADER  MEMTOP,6,'MEMTOP',DOCON
        DW USERFLASHEND 

;U   MEM       -- u    bytes left in flash
;       memtop ihere - ;
    HEADER  MEM,3,'MEM',DOCOLON
        DW MEMTOP,IHERE,MINUS
        DW EXIT
        
;U   UNUSED    -- u    bytes left in RAM
    HEADER UNUSED,6,'UNUSED',DOCOLON
        DW lit,RAMEND,HERE,MINUS
        DW EXIT

;Z   VARBOT     -- a-addr     bottom of Variable Area
    HEADER  VARBOT,6,'VARBOT',DOCON
        DW VARAREA

EXTERN intseg,intvecs
;Z   TOPSEG     -- a-addr     bottom of top most segment
    HEADER  TOPSEG,6,'TOPSEG',DOCON
        DW intseg

;Z   VECBOT     -- a-addr     begining of vector segment
    HEADER  VECBOT,6,'VECBOT',DOCON
        DW intvecs


;U   ?       adr -- u      display content of variable          
;       @ u. ;
        HEADER  QQ,1,'?',DOCOLON
        DW FETCH,UDOT
        DW EXIT


; MCU Peripherie ---------------------------------------------------------------

;Z   P1    -- adr       address of port1 output register 
    HEADER  P1,2,'P1',DOCON
        DW P1OUT

;Z   P2    -- adr       address of port2 output register 
    HEADER  P2,2,'P2',DOCON
        DW P2OUT

;Z   P3    -- adr       address of port2 output register 
    HEADER  P3,2,'P3',DOCON
        DW P3OUT

; Note: the first character sent from the MSP430 seems to get
; scrambled.  I conjecture this is because the baud rate generator
; has not reset to the new rate when we attempt to send a character.
; See init430f1611.s43 for delay after initialization.

; EOF