hilvl430FR.s43

; High Level Words - MSP430F5739  ; M.Kalus juli 2011
; Template was: hilvl430f1611.s43 
; for TI MSP430F1611 by B. Rodriguez  4 Jan 09

; ----------------------------------------------------------------------
; CamelForth for the Texas Instruments MSP430 
; (c) 2009 Bradford J. Rodriguez.
; 
; 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/>.
;
; Commercial inquiries should be directed to the author at 
; 115 First St., #105, Collingwood, Ontario L9Y 4W3 Canada
; or via email to bj@camelforth.com

; ----------------------------------------------------------------------
;   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.
;   U for utility words. A for application.
; ----------------------------------------------------------------------
; REVISION HISTORY

;mk Please debug COMPILER words.


; jul 2011 mk - no need for FLERASE I! IC! I@ IC@ D->I in FRAM, deleted. 
;   HARVARD MODEL EXTENSIONS deleted. 
;   Didnt use HWORD etc., did it like MSP430 Z80 souce code.
;   changed all Ixxx to xxx. 
;   changed label PAREN to LPAREN.
;   Modifyed MARKER for use in FRAM. 
;   S" adjusted.
;   .S gforth style.

; 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 - modified QUIT for Xon/Xoff flow control
; 4 jan 09 - created from Camel86h.asm.

; ----------------------------------------------------------------------

        EXTERN initDECON,CFid,CFver,intvecs,cory,srtA

; 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 APP      -- a-addr        xt of app ( was TURNKEY)
;    20 USER APP
    HEADER  APP,3,'APP',DOUSER
        DW 20

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

;Z FENCE   -- a-addr       we dont forget words below fence
;   24 USER FENCE
    HEADER  FENCE,5,'FENCE',DOUSER
        DW 24
 
; user variables 26,28,30 tbd



;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 #init    -- n    #bytes of user area init data
    HEADER  NINIT,5,'#INIT',DOCON
;        DW (UAREA_SIZE+VECS_SIZE)*2     ; SIZEs given in cells
          DW UAREA_SIZE*2 

; MEMTOP   -- adr     last cell of FRAM
    HEADER  MEMTOP,6,'MEMTOP',DOCON
          DW intvecs-2

; CORY      -- adr    cause of reset, holds copy of SYSRSTIV
    HEADER  CORY,4,'CORY',DOCON
          DW cory     

; 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 FM/MOD   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

;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
;   >R >R 2DUP R> R> 2SWAP ;
    HEADER  TWOOVER,5,'2OVER',DOCOLON
        DW TOR,TOR,TWODUP,RFROM,RFROM
        DW TWOSWAP,EXIT

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

;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 CR      --               output newline
;   0D EMIT 0A EMIT ;
    HEADER  CR,2,'CR',DOCOLON
        DW lit,0dh,EMIT,lit,0ah,EMIT,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 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
        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
ACC3:   DW OVER,CSTORE,ONEPLUS,OVER,UMIN
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  TYPE,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


;Z (S")     -- c-addr u   run-time code for S"
; get address and length of string in FRAM. 
;   R>            -- adr0  
;   COUNT         -- adr1 n 
; skip string 
;   OVER OVER +   -- adr1 n  adr1+n  
;   ALIGNED >R 
;   EXIT
; 
    HEADER  XSQUOTE,4,'(S")',DOCOLON 
        DW RFROM,COUNT 
;mk        DW OVER,OVER,PLUS 
        DW TWODUP,PLUS 
        DW ALIGNED,TOR 
        DW EXIT 

;C S"       --             compile in-line string
; in FRAM it goes like this: 
;   COMPILE (S")  [ HEX ]
;   22 WORD C@ 1+ ALIGNED ALLOT ; IMMEDIATE
    IMMED  SQUOTE,2,'S"',DOCOLON
        DW lit,XSQUOTE,COMMAXT
        DW lit,22H,WORDD,CFETCH,ONEPLUS
        DW ALLOT,ALIGNN,EXIT

;C ."       --         compile string to print
;   POSTPONE S"  POSTPONE TYPE ; IMMEDIATE
    IMMED  DOTQUOTE,2,'."',DOCOLON
        DW SQUOTE
        DW lit,TYPE,COMMAXT
        DW EXIT

; 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,lit,0,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,lit,0,NUMS,NUMGREATER,TYPE
        DW SPACE,EXIT

;C .     n --           display n signed
;   <# DUP ABS 0 #S ROT SIGN #> TYPE SPACE ;
    HEADER  DOT,1,'.',DOCOLON
        DW LESSNUM,DUP,ABBS,lit,0,NUMS
        DW ROT,SIGN,NUMGREATER,TYPE,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

; 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.

;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

;C WORD   char -- c-addr n   word delim'd by char
;   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 COUNT
        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,CFETCH,lit,1,ANDD,ZEROEQUAL,EXIT

; FIND-NAME  c-adr -- a nfa  OR  a 0     factor of FIND  
;   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
    HEADER  FINDNAME,9,'FIND-NAME',DOCOLON
        DW LATEST,FETCH
FIND1:  DW TWODUP,OVER,CFETCH,CHARPLUS
        DW NEQUAL,DUP,qbran
        DEST  FIND2
        DW DROP,NFATOLFA,FETCH,DUP
FIND2:  DW ZEROEQUAL,qbran
        DEST  FIND1
        DW EXIT

;C FIND   c-addr -- c-addr 0   if not found
;C                  xt  1      if immediate
;C                  xt -1      if "normal"
;   FIND-NAME
;   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 FINDNAME
        DW DUP,qbran
        DEST  FIND3
        DW NIP,DUP,NFATOCFA
        DW SWAP,IMMEDQ,ZEROEQUAL,lit,1,ORR
FIND3:  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,COMMA
LITER1: DW EXIT

;Z DIGIT?   c -- n -1   if c is a valid digit
;Z            -- x  0   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
;Z  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'
;C                      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                 -- 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,lit,0,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
;Z                      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
;       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,lit,0,TOIN,STORE
INTER1: DW BLANK,WORDD,DUP,CFETCH,qbran
        DEST  INTER9
        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,TYPE,lit,3FH,EMIT,CR,ABORT  ; <word> ? 
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

;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,lit,0,STATE,STORE
QUIT1:  DW CR  ; CR hier hin verlagert mk
        DW lit,11H,EMIT         ; send XON
        DW TIB,DUP,TIBSIZE,ACCEPT
        DW lit,13H,EMIT         ; send XOFF
        DW SPACE
        DW INTERPRET
;        DW CR,STATE,FETCH,ZEROEQUAL,qbran
        DW STATE,FETCH,ZEROEQUAL,qbran
        DEST  QUIT2
        DW XSQUOTE
        DB 3,'ok '
        DW TYPE
QUIT2:  DW bran
        DEST  QUIT1

;C ABORT    i*x --   R: j*x --   clear stk & QUIT
;   S0 SP!  QUIT ;
    HEADER  ABORT,5,'ABORT',DOCOLON
        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 TYPE,ABORT
QABO1:  DW TWODROP,EXIT

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

;C '    -- xt           find word in dictionary
;   BL WORD FIND
;   0= ABORT" ?" ;
    HEADER  TICK,1,27h,DOCOLON
        DW BLANK,WORDD,FIND,ZEROEQUAL,XSQUOTE
        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 COMMA,EXIT

;C (    --                     skip input until )
;   [ HEX ] 29 WORD DROP ; IMMEDIATE
    IMMED  LPAREN,1,'(',DOCOLON    
        DW lit,29H,WORDD,DROP,EXIT

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

;Z HEADER   --      create a Forth word header
;mk   ALIGN                  Headers in MSP430 FRAM space must be aligned.
;   LATEST @ , 0FF C,      link & IMMED  field
;   HERE LATEST !           new "latest" link
;   BL HWORD C@ 1+ ALLOT    name field
;   ALIGN ;
    HEADER  HEADR,6,'HEADER',DOCOLON
        DW ALIGNN  ; mk
        DW LATEST,FETCH,COMMA      ; compile link to latest word
        DW lit,0FFh,CCOMMA         ; compile immediate flags - see note below
        DW HERE,LATEST,STORE       ; save current position to latest
        DW BLANK,WORDD,CFETCH,ONEPLUS,ALLOT
        DW ALIGNN,EXIT   

;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
;mk        DW HEADR,lit,2,IALLOT,EXIT
        DW HEADR,lit,2,ALLOT,EXIT

;C CREATE   --      create an empty definition
;   HEADER
;mk   docreate , ;              code field
;mk FRAM is in continuous address space.
    HEADER  CREATE,6,'CREATE',DOCOLON
        DW HEADR
        DW lit,docreate,COMMACF
;mk        DW HERE,ICOMMA,EXIT   ; this was for flash versions
        DW 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 lit,0,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,FETCH,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,CSTORE
        DW EXIT

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

;C ;
;   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
        DW COMMA,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,XSQUOTE
        DB 1,'?'
        DW QABORT,ZEROLESS,qbran
        DEST  POST1
        DW lit,lit,COMMAXT,COMMA
        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
;mk        DW IHERE,COMMANONE,EXIT
        DW HERE,COMMANONE,EXIT

;C THEN     adrs --        resolve forward branch
;   IHERE SWAP !DEST ; IMMEDIATE
    IMMED  THEN,4,'THEN',DOCOLON
;mk        DW IHERE,SWAP,STOREDEST,EXIT
        DW HERE,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
;mk        DW IHERE,COMMANONE
        DW HERE,COMMANONE
        DW SWAP,THEN,EXIT

;C BEGIN    -- adrs        target for bwd. branch
;   IHERE ; IMMEDIATE
    IMMED  BEGIN,5,'BEGIN',DOCOLON
;mk        DW IHERE,EXIT
        DW HERE,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
;   ['] xdo ,XT   IHERE     target for bwd branch
;   0 >L ; IMMEDIATE           marker for LEAVEs
    IMMED  DO,2,'DO',DOCOLON
;mk        DW lit,xdo,COMMAXT,IHERE
        DW lit,xdo,COMMAXT,HERE
        DW lit,0,TOL,EXIT

;Z ENDLOOP   adrs xt --   L: 0 a1 a2 .. aN --
;   ,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 --
;   ['] xloop ENDLOOP ;  IMMEDIATE
    IMMED  LOO,4,'LOOP',DOCOLON
        DW lit,xloop,ENDLOOP,EXIT

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

;C LEAVE    --    L: -- adrs
;   ['] 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 HERE,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   system query
;                         -- i*x true
;   2DROP 0 ;       the minimal definition!
    HEADER  ENVIRONMENTQ,12,'ENVIRONMENT?',DOCOLON
        DW TWODROP,lit,0,EXIT

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

;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,lit,0,xdo 
onems1:  DW lit,11,lit,0,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 lit,0,xdo
ms1:     DW ONEMS,xloop
         DEST ms1
         DW EXIT

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

;U TRUE    -- FFFF    true flag
    HEADER TRUE,4,'TRUE',DOCON
          DW -1 

;U FALSE   -- 0    false flag
    HEADER FALSE,5,'FALSE',DOCON
          DW 0

;U NOOP     --     no operation
        HEADER NOOP,4,'NOOP',DOCOLON
        DW 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 CR ;m
        DW LATEST,FETCH
WDS1:   DW DUP,COUNT,lit,07FH,ANDD,TYPE,SPACE
        DW NFATOLFA,FETCH
        DW DUP,ZEROEQUAL,qbran
        DEST  WDS1
        DW DROP,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 TOR,LESSNUM,lit,0,NUMS,NUMGREATER
        DW RFROM,OVER,MINUS,lit,0,MAX,SPACES,TYPE,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
;   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,MINUS,qbran
        DEST  DOTS2
        DW SPFETCH,S0,lit,2,MINUS,xdo
DOTS1:  DW II,FETCH,UDOT,lit,-2,xplusloop
        DEST  DOTS1
DOTS2:  DW EXIT

;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 

/**  comment out if you can load files
;U .(         --     dotparen 
; type comment immediatly. 
;   $29 word count type  
    IMMED DOTPAREN,2,'.(',DOCOLON
        DW lit,29H,WORDD,COUNT,TYPE
        DW EXIT
 **/

;U MEM       -- n    bytes left in FRAM
    HEADER  MEM,3,'MEM',DOCOLON    
        DW BASE,FETCH,TOR,DECIMAL
        DW MEMTOP,HERE,MINUS,UDOT
        DW RFROM,BASE,STORE
        DW EXIT

;U FORGET   "word"  --     forget words till "word"  
    HEADER  FORGET,6,'FORGET',DOCOLON
        DW BLANK,WORDD,FINDNAME     ; -- a nfa  |  a 0 
        DW DUP,ZEROEQUAL,XSQUOTE    ; dup 0= if abort" ?" then
        DB 1,'?'
        ; EVEN
        DW QABORT
        DW DUP,FENCE,FETCH,LESS,XSQUOTE
        DB 7,' fence!' ; EVEN
        DW QABORT
        DW DUP,NFATOLFA,DDP,STORE   ; -- a nfa       ( reset here )
        DW NFATOLFA,FETCH           ; -- a nfa'      ( LFA @ is lower nfa )
        DW LATEST,STORE             ; -- a
        DW DROP
        DW EXIT


;U PROTECT     adr -- adr     abort if adr points to protected area.
;  DUP 1800 1C00 WITHIN >R
;  DUP C200 HERE WITHIN >R 
;  DUP FF80 FFFF WITHIN 
;  R> R> OR OR  IF ABORT" no!" THEN ; 
    HEADER PROTECT,7,'PROTECT',DOCOLON
        DW DUP,lit,$1800,lit,$1C00,WITHIN,TOR  ; protect info area
        DW DUP,lit,$C200,HERE,WITHIN,TOR       ; protect forth system
        DW DUP,lit,$FF80,lit,$FFFF,WITHIN      ; protect vector area
        DW RFROM,RFROM,ORR,ORR
        DW XSQUOTE 
        DB 3,'no!'                    ;
        DW QABORT
        DW EXIT 

; START UP =====================

/***  Boot process *************************************************
MCU does its internal boot, setting registers, then jumps to reset.
Reset interrupt service routine inits registers we use.
Ends up setting forth registers with IP pointing to WARM then.
Now Forth runs WARM first executing xt found in APP.
Then comes to QUIT waiting for terminal input.

COLD copys delivery condition tabel from infoA into user area.
WARM resets stacks, user area untouched. 

Bootquellen: slau272: 1.16 SYS Configuration Registers; S.43
*********************************************************************/

;Z  dcn  -- addr     adr of table with delivery conditions for user area
    HEADER  dcn,3,'dcn',DOCON
        DW initDECON

;Z .VER     --     type message   
        HEADER  DOTVER,4,'.VER',DOCOLON
        DW CR,lit,CFver,COUNT,TYPE 
        DW EXIT

;Z COLD      --      reset user area and stacks, then restart forth.
; copy uinit tabel from infoA to user area
    HEADER  COLD,4,'COLD',DOCOLON
        DW dcn,U0,NINIT,CMOVE 
        DW WARM,EXIT

;Z WARM     --      reset stacks and restart forth..
    HEADER  WARM,4,'WARM',DOCOLON
        DW APP,FETCH,EXECUTE      ; execute application
        DW lit,'>',EMIT,ABORT,EXIT
        
PUBLIC COLDIP,WARMIP  ; we use them to init IP register.
COLDIP   equ COLD+2
WARMIP   equ WARM+2

; finis  mk