; 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 .
;
; 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"
; >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 ; ?
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 ) -- 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
; 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<=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
; 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