; ----------------------------------------------------------------------
; 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 .
;
; 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
; ----------------------------------------------------------------------
; hilvl430.s43 - High Level Words - MSP430F1611
; B. Rodriguez 4 Jan 09
; 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.
; ----------------------------------------------------------------------
; REVISION HISTORY
; 30 Mar 2012 mk fixed FM/MOD
; 26 Feb 2012 mk - adopted to MSP430G2553
; MEM ( -- n ) n = bytes left in flash
; FLASHEND constant MEMTOP
; FLASHSTART constant MEMBOT
; kernel at $E000, IDP = FLASHSTART = C000
; fixed backspace.
; ok promt at end of line.
; .S prints depth.
;
; 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 xt of app ( was TURNKEY)
; 24 USER APP
HEADER APP,3,'app',DOUSER
DW 24
;Z CAPS -- a-addr capitalize words
; 26 USER CAPS
HEADER CAPS,4,'caps',DOUSER
DW 26
;Z emitvec -- a-addr xt of emit
; 28 USER CAPS
HEADER EMITVEC,7,'emitvec',DOUSER
DW 28
; user variables 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 uinit -- addr initial values for user area
; MSP430: we also use this to initialize the RAM interrupt
; vectors, which immediately follow the user area.
; Per init430f1611.s43, allocate 16 cells for user
; variables, followed by 30 cells for interrupt vectors.
HEADER UINIT,5,'uinit',DOROM
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 FLASHSTART ; IDP
DW 0 ; NEWEST not init'd
DW DOTCOLD ; app
DW 0 ; CAPS off is default
DW 0 ; EMIT ; XT of EMIT
DW 0 ; user variables TBD
/* not there mk
; 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 (UAREA_SIZE)*2 ; SIZEs given in cells
EXTERN cor,infoB,AppU0
;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 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 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"
; >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
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
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 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
; 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
;C IS" -- compile in-line string
; 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 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,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,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,lit,0,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.
;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.
;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 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 xt 1 if immediate
;C 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
/*
; use this if kernel words are upper case
;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
*/
; use this if kernel words are lower case
;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', MINUS
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 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
; 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,lit,0,TOIN,STORE
INTER1: 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,lit,3FH,EMIT,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 STATE,FETCH,ZEROEQUAL,qbran
DEST DOT1
DW XISQUOTE
DB 2,'> ' ; for prefix prompt amforth style
EVEN
DW ITYPE
; ENDIF
DOT1: DW EXIT
; C PROMPT -- prompt user
HEADLESS PROMPT,DOCOLON
; IF PREFIXPROMPT!=1
; DW CR
; DW STATE,FETCH,ZEROEQUAL,qbran
; DEST PROMPT1
DW XISQUOTE
DB 3,' ok' ; for amforth style
EVEN
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,lit,0,STATE,STORE
QUIT1:
DW STATE,FETCH,ZEROEQUAL,qbran
DEST QUIT2
DW DOTSTATUS
QUIT2: DW TIB,DUP,TIBSIZE,ACCEPT
DW CR
; 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
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 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 WORD DROP ; IMMEDIATE
IMMED PAREN,1,'(',DOCOLON
DW lit,29H,WORDD,DROP,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 ) -- 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,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
; 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
; ['] xdo ,XT IHERE target for bwd branch
; 0 >L ; IMMEDIATE marker for LEAVEs
IMMED DO,2,'do',DOCOLON
DW lit,xdo,COMMAXT,IHERE
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 IHERE,COMMANONE,TOL,EXIT
; OTHER OPERATIONS ==============================
;X WITHIN n1|u1 n2|u2 n3|u3 -- f n2<=n1R - 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
;U 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
; 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
WDS1: DW DUP,HCOUNT,lit,07FH,ANDD,HTYPE,CR
DW NFATOLFA,HFETCH
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,TYP,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,xdo
DOTS1: DW II,FETCH,UDOT,lit,-2,xplusloop
DEST DOTS1
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',DOCOLON
DW lit,8,LSHIFT,XORR
DW lit,8,lit,0,xdo
ccrc1: DW DUP,lit,1,LSHIFT,SWAP,lit,08000h,ANDD,ZEROEQUAL
DW INVERT,lit,01021h,ANDD,XORR
DW xloop
DEST ccrc1
DW EXIT
;U (crc n addr len -- n' crc process string
; dup IF over + swap DO ( n ) I C@ ccrc LOOP ELSE 2drop THEN ;
HEADER PCRC,4,'(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
;U crc addr len -- n
HEADER CRC,3,'crc',DOCOLON
DW lit,0,ROT,ROT,PCRC,EXIT
;U STARTUP WORDS =====================
;Z ITHERE -- adr find first free flash cell
; MEMTOP BEGIN 1-
; DUP C@ FF <>
; OVER FL0 < OR UNTIL 1+ ;
HEADER ITHERE,6,'ithere',DOCOLON
DW MEMTOP
ih1 DW ONEMINUS,DUP,CFETCH,lit,$FF,NOTEQUAL
DW OVER,MEMBOT,LESS,ORR,qbran
DEST ih1
DW ONEPLUS,EXIT
;U APPCRC -- crc CRC of APP-dictionary
; 0 MEMBOT ITHERE OVER - (crc APPU0 #INIT (crc ;
HEADER APPCRC,6,'appcrc',DOCOLON
DW lit,0
DW MEMBOT,ITHERE,OVER,MINUS,PCRC
DW APPU0,NINIT,PCRC,EXIT
EXTERN crcval
;U VALID? -- f check if user app crc matches infoB
; APPCRC crcval I@ = ;
HEADER VALIDQ,6,'valid?',DOCOLON
DW APPCRC,lit,crcval,IFETCH,EQUAL,EXIT
;U SAVE -- save user area to infoB
; InfoB [ 63 2 + ] Literal FLERASE
; U0 APPU0 #INIT D->I
; APPCRC [ crcval ] Literal I! ;
HEADER SAVE,4,'save',DOCOLON
DW INFOB,lit,63+2,FLERASE
DW U0,APPU0,NINIT,DTOI
DW APPCRC,lit,crcval,ISTORE
DW EXIT
CORREST EQU 018Eh
CORPOWERON EQU 0186h
;Z BOOT -- boot system
HEADER BOOT,4,'boot',DOCOLON
DW DOTVER
DW S2,cget,qbran
DEST boot1
DW VALIDQ,qbran
DEST invalid
valid: DW COLD ; valid infoB and dictionary
invalid:DW COR,FETCH,lit,CORPOWERON,NOTEQUAL,qbran
DEST boot1
reset: ; reset and invalid infoB
DW LATEST,FETCH,MEMBOT,ITHERE,WITHIN,qbran ; check RAM latest
DEST boot1
DW WARM ; invalid infoB but seemingly valid RAM
boot1: DW WIPE ; invalid infoB but power on or RAM invalid
PUBLIC BOOTIP ; used to init IP register.
BOOTIP equ BOOT+2
;Z WARM -- use user area from RAM (hopefully intact)
HEADER WARM,4,'warm',DOCOLON
DW XISQUOTE
DB (warm1-warm0)
warm0: DB 'Warm'
EVEN
warm1: DW ITYPE
DW ABORT
;U .COLD -- display COLD message
HEADLESS DOTCOLD,DOCOLON
DW XISQUOTE
DB (dotcold1-dotcold0)
dotcold0:DB 'Cold'
EVEN
dotcold1:DW ITYPE
DW EXIT
PUBLIC DOTCOLD
;Z COLD -- set user area to latest application
HEADER COLD,4,'cold',DOCOLON
DW APPU0,U0,NINIT,ITOD ; use application user area
DW APP,FETCH,EXECUTE ; AUTOSTART Application
DW ABORT
;Z FACTORY -- set user area to delivery condition
; UINIT U0 #INIT I->D SAVE init user area
; ABORT ;
HEADER FACTORY,7,'factory',DOCOLON
DW UINIT,U0,NINIT,ITOD ; use kernel user area
DW SAVE
DW ABORT ; ABORT never returns
PUBLIC FACTORYIP ; used to init IP register.
FACTORYIP equ FACTORY+2
;U WIPE -- erase flash but not kernel, reset user area.
HEADER WIPE,4,'wipe',DOCOLON
DW XISQUOTE
DB (wipmsg1-wipmsg0)
wipmsg0:DB 'Wiping'
EVEN
wipmsg1:DW ITYPE
DW MEMBOT,lit,FLASHEND-FLASHSTART+1,FLERASE
DW FACTORY ; EXIT
;U MISC ============================================================
;C 2CONSTANT -- define a Forth double constant
; (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
DW lit,version,COUNT,TYP
DW BASE,FETCH,BIN
DW COR,FETCH,DOT ; print cause of reset
DW BASE,STORE
DW EXIT
;U BELL -- send $07 to Terminal
HEADER BELL,4,'bell',DOCOLON
DW lit,7,EMIT,EXIT
;U BIN -- set number base to binary
HEADER BIN,3,'bin',DOCOLON
DW lit,2,BASE,STORE,EXIT
;U MCU specific 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 f_cpu -- u DCO in Khz
HEADER F_CPU,5,'f_cpu',DOCON
DW fcpu
;U Bit manipulation words ------------------------------------------------------
;U based on http://www.forth.org/svfig/Len/bits.htm
;U CSET mask addr -- set bit from mask in addr
HEADER cset,4,'cset',DOCODE
BIS.B @PSP,0(TOS)
ADD #2,PSP
MOV @PSP+,TOS
NEXT
;U CCLR mask addr -- reset bit from mask in addr
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
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
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
;U Memory info -----------------------------------------------------------------
;Z MEMBOT -- adr begining of flash
HEADER MEMBOT,6,'membot',DOCON
DW FLASHSTART
;Z MEMTOP -- adr end of flash
HEADER MEMTOP,6,'memtop',DOCON
DW FLASHEND
;U MEM -- n bytes left in FRAM
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
;U 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.