Gary Z
LPC8xx Forth in assembler, from a Kiel user Starting point for a Work In Progress
Fork of
ENORA-Forth
by 
Gérard Sontag
Original author reports this (original file) compiled with Kiel tools. It is for an NXP LPC812 processor on the 800MAX board. It is considered a Table Token Forth. ARM compiler/assembler is not as robust as the Kiel - per the original author.
Revision 1:d7744c74e50f, committed 2015-12-06
- Comitter:
- olzeke51
- Date:
- Sun Dec 06 05:18:41 2015 +0000
- Parent:
- 0:df922596d756
- Commit message:
- basic copy of original
Changed in this revision
| Forth.s | Show annotated file Show diff for this revision Revisions of this file |
| Forth_orig.s | Show annotated file Show diff for this revision Revisions of this file |
diff -r df922596d756 -r d7744c74e50f Forth.s
--- a/Forth.s Fri Dec 04 13:09:58 2015 +0000
+++ b/Forth.s Sun Dec 06 05:18:41 2015 +0000
@@ -15,6 +15,9 @@
AREA |.text|, CODE
; IMPORT __Vectors
THUMB
+;grz added this incluce
+#include "lpc8xx.s"
+
BuffSize EQU 64
;----------------------------------
; Values that can be customise
@@ -23,6 +26,9 @@
DataStackLength EQU 32 * 4 ; 32 cells
+; grz error correction - cjouldn't access the chip.s file for this value
+RAMForIAP EQU 128
+
; Then follow the return stack for a length of:
ReturnStackLength EQU 32 * 4 ; 32 cells
@@ -259,8 +265,8 @@
; INCLUDE yourfavoritechip.s
- GET lpc8xx.s
-
+ ; GET ./lpc8xx.s
+
;-(0)-------------------------------( -- 0 )
diff -r df922596d756 -r d7744c74e50f Forth_orig.s
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Forth_orig.s Sun Dec 06 05:18:41 2015 +0000
@@ -0,0 +1,1985 @@
+;
+; Continuer a coder interpret....
+;U/MOD a peut-être des soucis...
+; Impression numeriques KO
+;
+; : call >r ;
+; : twice: r> dup call call ;
+; : quadruple twice: dup + ;
+;
+; Voir pb des caractères de contrôle
+; TESTER WORD
+;
+ EXPORT Reset_Handler
+ EXPORT __initial_sp
+ AREA |.text|, CODE
+; IMPORT __Vectors
+ THUMB
+BuffSize EQU 64
+;----------------------------------
+; Values that can be customise
+; Data stack & Return Stack are @ the begining
+; of Data Memory area
+
+DataStackLength EQU 32 * 4 ; 32 cells
+
+
+; Then follow the return stack for a length of:
+
+ReturnStackLength EQU 32 * 4 ; 32 cells
+
+; Then follow internal values
+; UserVar EQU 64 * 4 ; 64 cells
+;-----------------------------------
+; Registers allocation |
+; They are in this way to allow |
+; the use of r0 r1 r2 r3 |
+; to call subroutine |
+;-----------------------------------
+ ALIAS r0, WRK0 ; WoRK0 register
+ ALIAS r1, WRK1 ; WoRK1 register
+ ALIAS r2, WRK2 ; WoRK2 register
+ ALIAS r3, WRK ; WoRK register
+ ALIAS r4, IPTR ; Instruction PoinTeR
+ ALIAS r5, NXT ; Contain the NeXT routine address
+ ALIAS r6, TOS ; Top Of Stack , stack managed by sp
+ ALIAS r7, RPTR ; Return stack PoinTeR
+;-----------------------------------
+; Flag used in dictionary |
+;-----------------------------------
+Cmponly EQU 0x20 ; Can't be interpreted
+Inline EQU 0x40 ; Indicate a word can be inline (future !)
+Immed EQU 0x80 ; Indicate the word must be run immediatly
+
+;-----------------------------------
+; Token equivalence
+;
+; If you know a better way
+; to define this with µVision
+; let me know
+; The order of the definition
+; of the EQU don't matter
+; only the value itself is important
+; If you add a token don't forget
+; to add an entry in the token's addresses
+;-----------------------------------------------------
+;Token name ; Word
+
+Tick EQU (TokTab-wxTick)/4 ; .
+Dot EQU (TokTab-wxDot)/4 ; .
+UDot EQU (TokTab-wxUDot)/4 ; U.
+Sign EQU (TokTab-wxSign)/4 ; SIGN
+NumStr EQU (TokTab-wxNumStr)/4 ; #S
+StrPic EQU (TokTab-wxStrPic)/4 ; <#
+Numb EQU (TokTab-wxNumb)/4 ; #
+EndPic EQU (TokTab-wxEndPic)/4 ; #>
+Abs EQU (TokTab-wxAbs)/4 ; ABS
+Str EQU (TokTab-wxStr)/4 ; STR
+Hold EQU (TokTab-wxHold)/4 ; HOLD
+Extract EQU (TokTab-wxExtract)/4 ; EXTRACT
+Hld EQU (TokTab-wxHld)/4 ; HLD
+Pad EQU (TokTab-wxPad)/4 ; PAD
+UMSMod EQU (TokTab-wxUMSMod)/4 ; UM/MOD
+MSMod EQU (TokTab-wxMSMod)/4 ; M/MOD
+SMod EQU (TokTab-wxSMod)/4 ; /MOD
+Neg EQU (TokTab-wxNeg)/4 ; NEGATE
+RAt EQU (TokTab-wxRAt)/4 ; R@
+IsNull EQU (TokTab-wxIsNull)/4 ; 0=
+ULess EQU (TokTab-wxUless)/4 ; U<
+Mul EQU (TokTab-wxMul)/4 ; *
+DotS EQU (TokTab-wxDotS)/4 ; .S
+Inter EQU (TokTab-wxInter)/4 ; INTERPRET
+Word EQU (TokTab-wxWord)/4 ; WORD
+toIn EQU (TokTab-wxtoIn)/4 ; >IN
+nTib EQU (TokTab-wxnTib)/4 ; #TIB
+State EQU (TokTab-wxState)/4 ; STATE
+RS0 EQU (TokTab-wxFalse)/4 ; not a user token
+False EQU (TokTab-wxFalse)/4 ; FALSE
+True EQU (TokTab-wxTrue)/4 ; TRUE
+DNeg EQU (TokTab-wxDNeg)/4 ; DNEGATE
+DPlus EQU (TokTab-wxDPlus)/4 ; D+
+DMinus EQU (TokTab-wxDMinus)/4 ; D-
+IsNeg EQU (TokTab-wxIsNeg)/4 ; <0
+TDup EQU (TokTab-wxTDup)/4 ; 2DUP
+UMPlus EQU (TokTab-wxUMPlus)/4 ; UM+
+TDrop EQU (TokTab-wx2Drop)/4 ; 2DROP
+Fill EQU (TokTab-wxFill)/4 ; FILL
+Foursta EQU (TokTab-wxFoursta)/4 ; 4*
+MRot EQU (TokTab-wxMRot)/4 ; -ROT
+Rot EQU (TokTab-wxRot)/4 ; ROT
+Dec EQU (TokTab-wxDec)/4 ; DECIMAL
+Base EQU (TokTab-wxBase)/4 ; BASE
+Toupp EQU (TokTab-wxToupp)/4 ; TOUPPER
+Find EQU (TokTab-wxFind)/4 ; FIND
+Upper EQU (TokTab-wxUpper)/4 ; UPPER
+Count EQU (TokTab-wxCount)/4 ; COUNT
+Type EQU (TokTab-wxType)/4 ; TYPE
+Words EQU (TokTab-wxWords)/4 ; WORDS
+CAt EQU (TokTab-wxCAt)/4 ; C@
+At EQU (TokTab-wxAt)/4 ; @
+Bl EQU (TokTab-wxBl)/4 ; BL
+Space EQU (TokTab-wxSpace)/4 ; SPACE
+Spaces EQU (TokTab-wxSpaces)/4 ; SPACES
+CStore EQU (TokTab-wxCStore)/4 ; C!
+Store EQU (TokTab-wxStore)/4 ; !
+Swap EQU (TokTab-wxSwap)/4 ; SWAP
+Accept EQU (TokTab-wxAccept)/4 ; ACCEPT
+Key EQU (TokTab-wxKey)/4 ; KEY
+BCode EQU (TokTab-wxBCode)/4
+Ten EQU (TokTab-wxTen)/4 ; #10
+Two EQU (TokTab-wxTwo)/4 ; #2
+One EQU (TokTab-wxOne)/4 ; 1
+Zero EQU (TokTab-wxZero)/4 ; 0
+Within EQU (TokTab-wxWithin)/4 ; WITHIN
+FromR EQU (TokTab-wxFromR)/4 ; R>
+ToR EQU (TokTab-wxToR)/4 ; >R
+Digit EQU (TokTab-wxDigit)/4 ; DIGIT
+Not EQU (TokTab-wxNot)/4 ; NOT
+Xor EQU (TokTab-wxXor)/4 ; XOR
+Or EQU (TokTab-wxOr)/4 ; OR
+And EQU (TokTab-wxAnd)/4 ; AND
+Eq EQU (TokTab-wxEq)/4 ; =
+Gt EQU (TokTab-wxGt)/4 ; >
+Lt EQU (TokTab-wxLt)/4 ; <
+Over EQU (TokTab-wxOver)/4 ; OVER
+Cr EQU (TokTab-wxCr)/4 ; CR
+Max EQU (TokTab-wxMax)/4 ; MAX
+Min EQU (TokTab-wxMin)/4 ; MIN
+Plus1 EQU (TokTab-wxPlus1)/4 ; 1+
+Minus1 EQU (TokTab-wxMinus1)/4 ; 1-
+Snap EQU (TokTab-wxSnap)/4
+DupNZ EQU (TokTab-wxDupNZ)/4 ; ?DUP
+Dup EQU (TokTab-wxDup)/4 ; DUP
+Minus EQU (TokTab-wxMinus)/4 ; -
+Lit8 EQU (TokTab-wxdoLit8)/4
+Lit16 EQU (TokTab-wxdoLit16)/4
+Lit32 EQU (TokTab-wxdoLit32)/4
+Plus EQU (TokTab-wxPlus)/4 ; +
+Exit EQU (TokTab-wxExit)/4 ; EXIT
+Bra EQU (TokTab-wxBra)/4
+ZBra EQU (TokTab-wxZBra)/4
+Emit EQU (TokTab-wxEmit)/4 ; EMIT
+SpAt EQU (TokTab-wxSpAt)/4 ; SP@
+Sp0 EQU (TokTab-wxSp0)/4 ; SP0
+Slash4 EQU (TokTab-wxSlash4)/4 ; /4
+;USMod EQU (TokTab-wxUSMod)/4 ; U/MOD ?????
+Drop EQU (TokTab-wxDrop)/4 ; DROP
+Execute EQU (TokTab-wxExecute)/4 ; EXECUTE
+Depth EQU (TokTab-wxDepth)/4 ; DEPTH
+Lf EQU (TokTab-wxLf)/4 ; LF
+;-----------------------------------
+;Not so usefull macro...to be change
+ MACRO
+$lab LINK $p
+$lab DCD $p
+ MEND
+
+;-----------------------------------
+;Handy way to code the Next routine
+ MACRO
+$lab RET
+$lab BX NXT
+ MEND
+
+;-----------------------------------
+; These macro compute the displacement
+; which is store in a halfword aligned
+ MACRO
+$label Branch $target
+$label DCB Bra
+ DCW $target-.
+ MEND
+
+ MACRO
+$label ZBranch $target
+$label DCB ZBra
+ DCW $target-.
+ MEND
+
+;-----------------------------------????????????????????????
+; These macro Create Counted string
+ MACRO
+$label String $String
+$label DCB $String
+ MEND
+m0 DCB m2-m1
+m1 DCB "TOTO"
+m2 EQU .
+
+;-----------------------------------
+; High level routine doCol/Enter (save IPTR)
+; 8 bytes long for each high level word
+ MACRO
+$lab doCol ; !!! We come here from a BX WRK2 in the next routine see below
+$lab STR IPTR,[RPTR] ; Save Instruction pointer to the return Stack
+ ADDS RPTR, RPTR, #4 ; Update Return stack pointer
+ ADDS IPTR, WRK2, #7 ; Warning! adjusted to point after the RET Macro. Point to the first byte/token in the byte/token list
+ RET
+ MEND
+
+;-----------------------------------
+; The long next routine
+; we jump into it with a BX NXT
+; where NXT is the register which contain
+; the doNext address
+;-----------------------------------
+doNext LDR WRK2,=(TokTab) ; Last Table Entry address (Tok=0)
+ LDRB WRK, [IPTR] ; Get the token to be execute in the thread
+ CMP WRK, #255 ; Is it a one byte token or a multiple' one?
+ BEQ high ; go to next token (NOT IMPLEMENTED )
+ LSLS WRK, #2 ; Token number * 4 (word length)
+ SUBS WRK2, WRK2, WRK ; Compute the entry table address
+ ADDS IPTR, #1 ; Point to next token before running the actual one
+ LDR WRK2, [WRK2] ; Get the run address
+ BX WRK2 ; Go to it!
+high B high ; To be update latter when i will use 2 bytes tokens
+
+
+
+Reset_Handler
+ LDR RPTR, =Begin
+ LDR NXT, =doNext
+ BL UartConfig
+ LDR IPTR, =test18
+ BX NXT
+
+
+;-----------------------------------
+; Dictionary start here
+;-(EXIT)----------------------------
+LExit LINK 0 ; Link
+ DCB 4, "EXIT"
+xExit SUBS RPTR, RPTR, #4 ; Adjust the return stack pointer
+ LDR IPTR,[RPTR] ; Collect the value
+ RET
+
+;-----------------------------------
+; All specific code for a chip
+; Must be put in a separate file
+; see lpc8xx.s as an example
+; INCLUDE yourfavoritechip.s
+
+
+ ; GET ./lpc8xx.s
+
+
+
+;-(0)-------------------------------( -- 0 )
+LZero LINK LKey ; Link to LKey which is in the included file
+ DCB 1+Inline, "0"
+xZero PUSH {TOS}
+ MOVS TOS, #0
+ RET
+
+;-(1)-------------------------------( -- 1 )
+LOne LINK LZero ; Link
+ DCB 1+Inline,"1"
+xOne PUSH {TOS}
+ MOVS TOS, #1
+ RET
+
+;-(#2)-------------------------------( -- 2 )
+LTwo LINK LOne ; Link
+ DCB 2+Inline,"#2"
+xTwo PUSH {TOS}
+ MOVS TOS, #2
+ RET
+
+;-(#10)------------------------------( -- 10 )
+LTen LINK LTwo ; Link
+ DCB 3+Inline, "#10"
+xTen PUSH {TOS}
+ MOVS TOS, #10
+ RET
+
+;-(Plus1)---------------------------( n -- n+1 )
+LPlus1 LINK LTen ; Link
+ DCB 2+Inline, "1+"
+xPlus1 ADDS TOS, TOS, #1 ; Add 1 to TOS
+ RET
+
+;-(Minus1)--------------------------( n -- n-1 )
+LMinus1 LINK LPlus1 ; Link
+ DCB 2+Inline, "1-"
+xMinus1 SUBS TOS, TOS, #1 ; Substract 1 to TOS
+ RET
+
+;-(DUP)-----------------------------(x -- x,x)
+LDup LINK LMinus1 ; Link
+ DCB 3+Inline, "DUP"
+xDup PUSH {TOS} ; Push Top of stack onto the stack (sp pointing)
+ RET
+
+;-(2DUP)----------------------------(x2,x1 -- x2,x1,x2,x1)
+L2Dup LINK LDup ; Link
+ DCB 4, "2DUP"
+x2Dup POP {WRK} ; Get second element
+ PUSH {WRK} ; Put second element
+ PUSH {TOS} ; Put first element
+ PUSH {WRK} ; Put second element
+ RET ; First is still in TOS
+
+;-(doLit8)--------------------------( -- n )
+LdoLit8 LINK L2Dup ; Link
+ DCB 5, "Lit8" ; For value between -128,+127
+doLit8 PUSH {TOS} ; Make room
+ LDRB TOS,[IPTR] ; Collect the byte just after the token (IPTR pointing to it)
+ SXTB TOS, TOS ; Extent the sign
+ ADDS IPTR, #1 ; Jump over the byte
+ RET
+
+;-(doLit16)-------------------------( -- n )
+LdoLit16 LINK LdoLit8 ; Link
+ DCB 5, "Lit16"
+doLit16 PUSH {TOS} ; Make room
+ ADDS IPTR, IPTR, #1 ; Point to
+ LSRS IPTR, IPTR, #1 ; the next halfword
+ LSLS IPTR, IPTR, #1 ; boundary
+ LDRH TOS, [IPTR] ; Collect the halfword
+ SXTH TOS, TOS ; Extend the sign
+ ADDS IPTR, #2 ; Jump over the halfword
+ RET
+
+;-(doLit32)-------------------------( -- n )
+LdoLit32 LINK LdoLit16 ; Link
+ DCB 5, "Lit32"
+doLit32 PUSH {TOS}
+ ADDS IPTR, IPTR, #3 ; point to
+ LSRS IPTR, IPTR, #2 ; the next word
+ LSLS IPTR, IPTR, #2 ; boundary
+ LDR TOS, [IPTR]
+ ADDS IPTR, #4 ; Jump over the word
+ RET
+
+;-(OR)------------------------------( x1 x2 -- x3 )
+LOr LINK LdoLit32 ; Link
+ DCB 2,"OR"
+xOr POP {WRK} ; Get second parameter
+ ORRS TOS, TOS, WRK ; Or
+ RET
+
+;-(AND)-----------------------------( x1 x2 -- x3 )
+LAnd LINK LOr ; Link
+ DCB 3,"AND"
+xAnd POP {WRK} ; Get second parameter
+ ANDS TOS, TOS, WRK ; And
+ RET
+
+;-(XOR)-----------------------------( x1 x2 -- x3 )
+LXor LINK LAnd ; Link
+ DCB 3, "XOR"
+xXor POP {WRK} ; Get second parameter
+ EORS TOS, TOS, WRK ; Xor
+ RET
+
+;-(0<)------------------------------( n -- f)
+LIsNeg LINK LXor ; Link
+ DCB 2+Inline, "0<"
+xIsNeg ASRS TOS, TOS, #31 ; Extend the sign True=FFFFFFFF False=00000000
+ RET
+
+;-(0=)------------------------------( n -- f )
+LIsNull LINK LIsNeg ; Link
+ DCB 2, "0="
+xIsNull MOVS TOS,TOS ; test the value
+ BEQ Isnull1
+ SUBS TOS, TOS ; False
+ B IsNull2
+Isnull1 SUBS TOS,TOS,#1 ; True
+IsNull2 RET
+
+;-(0>)------------------------------( n -- f )
+LIsPos LINK LIsNull ; Link
+ DCB 2, "0>"
+xIsPos MOVS TOS,TOS
+ LDR TOS,=0x0 ; False
+ BNE IsPos1
+ BPL IsPos1
+ SUBS TOS,TOS,#1 ; True
+IsPos1 RET
+
+ LTORG
+;-(EXECUTE)-------------------------( xt -- )
+LExec LINK LIsPos ; Link
+ DCB 7+Inline, "EXECUTE"
+xExec ADDS WRK2, TOS, #1 ; Because of Thumb
+ POP {TOS} ; Update TOS
+ BX WRK2 ; We need to use WRK2 at the entry of a high level word. See doCol comment
+
+;-(DROP)-----------------------------(x -- )
+LDrop LINK LExec ; Link
+ DCB 4+Inline, "DROP"
+xDrop POP {TOS} ; Get previous element
+ RET
+
+;-(2DROP)---------------------------( x1 x2 -- )
+L2Drop LINK LDrop ; Link
+ DCB 5+Inline, "2DROP"
+x2Drop POP {TOS} ; Get previous element
+ POP {TOS} ; Get previous element
+ RET
+
+;-(SWAP)----------------------------( x1 x2 -- x2 x1 )
+LSwap LINK L2Drop ; Link
+ DCB 4, "SWAP"
+xSwap POP {WRK} ; Get x1
+ PUSH {TOS} ; Put x2
+ MOVS TOS,WRK ; Put x1
+ RET
+
+;-(OVER)----------------------------( x1 x2 -- x1 x2 x1 )
+LOver LINK LSwap ; Link
+ DCB 4+Inline, "OVER"
+xOver PUSH {TOS} ; Put x2
+ LDR TOS,[sp,#4] ; Get x1
+ RET
+
+;-(ROT)-----------------------------( x1 x2 x3 -- x2 x3 x1 )
+LRot LINK LOver ; Link
+ DCB 3, "ROT"
+xRot POP {WRK} ; Get x2
+ POP {WRK2} ; Get x1
+ PUSH {WRK} ; Put x2
+ PUSH {TOS} ; Put x3
+ MOV TOS,WRK2 ; Put x1
+ RET
+
+;-(-ROT)-----------------------------( x1 x2 x3 -- x3 x1 x2 )
+LMRot LINK LRot ; Link
+ DCB 4, "-ROT"
+xMRot POP {WRK} ; Get x2
+ POP {WRK2} ; Get x1
+ PUSH {TOS} ; Put x3
+ PUSH {WRK2} ; Put x1
+ MOV TOS,WRK ; Put x2
+ RET
+
+;-(NIP)-----------------------------( x1 x2 -- x2 )
+LNip LINK LMRot ; Link
+ DCB 3+Inline, "NIP"
+xNip POP {WRK} ; Discard x1
+ RET
+
+;-(TUCK)-----------------------------( x1 x2 -- x2 x1 x2 )
+LTuck LINK LNip ; Link
+ DCB 4, "TUCK"
+xTuck POP {WRK} ; Get x1
+ PUSH {TOS} ; Put x2
+ PUSH {WRK} ; Put x1
+ RET
+
+;-(+)-------------------------------( n1|u1 n2|u2 -- n3|u3 )
+LPlus LINK LTuck ; Link
+ DCB 1+Inline, "+"
+xPlus POP {WRK} ; Get n1|u1
+ ADDS TOS, TOS, WRK ; Add n2|u2
+ RET
+
+;-(-)-------------------------------( n1|u1 n2|u2 -- n3|u3 )
+LMinus LINK LPlus ; Link
+ DCB 1+Inline, "-"
+xMinus POP {WRK} ; Get n1|u1
+ SUBS TOS, WRK, TOS ; Substract from TOS
+ RET
+
+;-(2*)------------------------------
+LTwosta LINK LMinus ; Link
+ DCB 2+Inline, "2*"
+xTwoStar LSLS TOS, TOS, #1 ; Shift one bit
+ RET
+
+;-(2/)------------------------------
+LTwosla LINK LTwosta ; Link
+ DCB 2+Inline, "2/"
+xTwoSla ASRS TOS, TOS, #1 ; Shift one bit
+ RET
+
+;-(4*)------------------------------
+LFoursta LINK LTwosla ; Link
+ DCB 2+Inline, "4*"
+xFoursta LSLS TOS, TOS, #2 ; Shift two bits
+ RET
+
+;-(4/)------------------------------
+L4Slash LINK LFoursta ; Link
+ DCB 2+Inline, "4/"
+xSlash4 ASRS TOS, TOS, #2 ; Shift two bits
+ RET
+
+;-(LSHIFT)--------------------------(x1,u --- x2)
+LShift LINK L4Slash ; Link
+ DCB 6+Inline, "LSHIFT"
+xSixtn POP {WRK} ; Get x1
+ LSLS WRK, WRK, TOS ; Shift x1 u place to the left
+ MOVS TOS, WRK
+ RET
+
+;-(RSHIFT)--------------------------(x1,u --- x2)
+LRShift LINK LShift ; Link
+ DCB 6+Inline, "RSHIFT"
+ POP {WRK} ; Get x1
+ LSRS WRK, WRK, TOS ; Shift x1 u place to the right
+ MOVS TOS, WRK
+ RET
+
+;-(@)-------------------------------( a -- x )
+LAt LINK LRShift ; Link
+ DCB 1+Inline, "@"
+xAt LDR TOS, [TOS] ; Get the value pointed by TOS
+ RET
+
+;-(C@)------------------------------( a -- c )
+LCAt LINK LAt ; Link
+ DCB 2+Inline, "C@"
+xCAt LDRB TOS, [TOS] ; Get the caracter pointed by TOS
+ RET
+
+;-(H@)------------------------------( a -- h )
+LHAt LINK LCAt ; Link
+ DCB 2+Inline, "H@"
+xHAt LDRH TOS, [TOS] ; Get the halfword pointed by TOS
+ RET
+
+;-(!)-------------------------------(word,address --)
+LStore LINK LHAt ; Link
+ DCB 1+Inline, "!"
+xStore POP {WRK} ; Get value to store
+ STR WRK, [TOS] ; Store word where TOS point to
+ POP {TOS} ; Update TOS
+ RET
+
+;-(C!)------------------------------(char,addr--)
+LCStore LINK LStore ; Link
+ DCB 2+Inline, "C!"
+xCStore POP {WRK} ; Get value to store
+ STRB WRK, [TOS] ; Store Character value where TOS point to
+ POP {TOS} ; Update TOS
+ RET
+
+;-(H!)------------------------------(halfword,address --)
+LHStore LINK LCStore ; Link
+ DCB 2 ; Length
+ DCB "H!"
+xHStore POP {WRK} ; Get value to store
+ STRH WRK, [TOS] ; Store Halfword where TOS point to
+ POP {TOS}
+ RET
+
+;-(>R)------------------------------( n -- R:n)
+LToR LINK LHStore ; Link
+ DCB 2+Inline+Cmponly, ">R"
+xToR STR TOS,[RPTR] ; Put TOS on return stack
+ ADDS RPTR, #4 ; Adjust Stack pointer
+ POP {TOS} ; update TOS
+ RET
+
+;-(R>)------------------------------(R:n -- n)
+LFromR LINK LToR ; Link
+ DCB 2, "R>"
+xFromR PUSH {TOS} ; Make room
+ SUBS RPTR, RPTR, #4 ; Prepare to collect
+ LDR TOS, [RPTR] ; Collect value
+ RET
+;-(R@)------------------------------
+LRAt LINK LFromR ; Link
+ DCB 2, "R@"
+xRAt PUSH {TOS} ; Make room
+ MOVS TOS, RPTR ; Collect value
+ SUBS TOS, #4 ; Point to previous word
+ LDR TOS,[TOS] ; Get value
+ RET
+;-(NOT)-----------------------------
+LNot LINK LRAt ; Link
+ DCB 3+Inline, "NOT"
+xNot MVNS TOS, TOS ; move not
+ RET
+
+;-(branch)-------------------------- Branch & ZBranch use a halfword align displacement
+Lbranch LINK LNot ; Link
+ DCB 3, "BRA"
+xBra ADDS IPTR, #1 ; Point to
+ LSRS IPTR, IPTR, #1 ; the next halfword
+ LSLS IPTR, IPTR, #1 ; boundary
+ LDRH WRK, [IPTR] ; Get the displacement
+ SXTH WRK, WRK ; Extend the sign
+ ADDS IPTR, IPTR, WRK ; Compute destination address
+ RET
+
+;-(Zbranch)-------------------------
+LZbranch LINK Lbranch ; Link
+ DCB 4, "0BRA"
+xZBra TST TOS,TOS ; Update flags
+ POP {TOS} ;
+ BEQ xBra ; Take the branch if TOS = 0
+ ADDS IPTR, #1 ; Else compute
+ LSRS IPTR, IPTR, #1 ; the next halfword
+ LSLS IPTR, IPTR, #1 ; boundary
+ ADDS IPTR, #2 ; and jump over the halfword displacement
+ RET
+
+;-(NEGATE)--------------------------(n -- -n)
+LNegate LINK LZbranch ; Link
+ DCB 6+Inline, "NEGATE"
+xNeg MVNS TOS, TOS ; Move NOT signed
+ ADDS TOS, #1
+ RET
+
+;-(ABS)-----------------------------(n -- |n|)
+LAbs LINK LNegate ; Link
+ DCB 3, "ABS"
+xAbs TST TOS, TOS ; Test TOS
+ BPL Abs1 ; If positive do nothing
+ MOVS WRK, #0
+ SUBS TOS, WRK, TOS ; TOS = 0 - TOS
+Abs1 RET
+
+;-(MAX)-----------------------------(n1, n2 -- Max(n1,n2))
+LMax LINK LAbs ; Link
+ DCB 3, "MAX"
+xMax POP {WRK}
+ CMP WRK, TOS
+ BLT xMax1
+ MOVS TOS, WRK
+xMax1 RET
+
+;-(MIN)-----------------------------(n1, n2 -- Min(n1,n2))
+LMin LINK LMax ; Link
+ DCB 3, "MIN"
+xMin POP {WRK}
+ CMP WRK, TOS
+ BGT xMin1
+ MOVS TOS, WRK
+xMin1 RET
+
+;-(WITHIN)--------------------------
+LWithin LINK LMin ; Link
+ DCB 6, "WITHIN"
+xWithin doCol
+ DCB Over, Minus, ToR ; : Within Over - >R - R> U< ;
+ DCB Minus, FromR, ULess ;
+ DCB Exit
+
+;-(=)-------------------------------
+LEq LINK LWithin ; Link
+ DCB 1, "="
+xEq POP {WRK}
+ CMP WRK,TOS
+ LDR TOS, =0x0 ; False flag
+ BNE xEq1
+ SUBS TOS, #1 ; True
+xEq1 RET
+
+;-(<)-------------------------------
+LLt LINK LEq ; Link
+ DCB 1, "<"
+xLt POP {WRK}
+ CMP WRK,TOS
+ LDR TOS, =0x0
+ BGE xLt1
+ SUBS TOS, #1
+xLt1 RET
+
+;-(>)-------------------------------
+LGt LINK LLt ; Link
+ DCB 1, ">"
+xGt POP {WRK}
+ CMP WRK,TOS
+ LDR TOS, =0x0
+ BLE xGt1
+ SUBS TOS, #1
+xGt1 RET
+
+;-(INVERT)--------------------------
+LInvert LINK LGt ; Link
+ DCB 6+Inline, "INVERT"
+xInvert MVNS TOS, TOS
+ RET
+
+;-(?DUP)----------------------------(n -- n,n | n)
+LDupNZ LINK LInvert ; Link
+ DCB 4, "?DUP"
+xDupNZ TST TOS, TOS ; Test TOS
+ BEQ DupNZ1 ; If 0 do nothing
+ PUSH {TOS} ; Duplicate
+DupNZ1 RET
+
+;-(*)-------------------------------
+LMul LINK LDupNZ ; Link
+ DCB 1+Inline, "*"
+xMul POP {WRK} ; Get 2nd Element
+ MULS TOS, WRK, TOS ; Multiply
+ RET
+
+;-(+!)------------------------------
+LAddSto LINK LMul ; Link
+ DCB 2, "+!"
+xAddSto POP {WRK}
+ LDR WRK2, [TOS]
+ ADDS WRK, WRK, WRK2
+ STR WRK, [TOS]
+ POP {TOS}
+ RET
+
+;-(-!)------------------------------
+LSubSto LINK LAddSto ; Link
+ DCB 2, "-!"
+xSubSto POP {WRK}
+ LDR WRK2, [TOS]
+ SUBS WRK, WRK, WRK2
+ STR WRK, [TOS]
+ POP {TOS}
+ RET
+
+;-(CELL)---------------------------
+LCell LINK LSubSto ; Link
+ DCB 4+Inline, "CELL"
+xCell PUSH {TOS}
+ MOVS TOS, #4 ; Cells are 4 bytes
+ RET
+
+;-(SP0)---------------------------
+LSP0 LINK LCell ; Link
+ DCB 3, "SP0"
+xSp0 SUBS WRK, WRK ; Cortex M0+ initial stack value address : 0
+ LDR WRK, [WRK]
+ PUSH {TOS}
+ MOV TOS, WRK
+ RET
+
+;-(SP@)-----------------------------
+LSPAt LINK LSP0 ; Link
+ DCB 3, "SP@"
+xSpAt MOV WRK, sp ; Collect the value before push!
+ PUSH {TOS}
+ MOV TOS, WRK ; Update
+ RET
+
+;-(DEPTH)---------------------------: Depth SP@ SP0 - /4 ; 14 bytes
+LDepth LINK LSPAt ; Link
+ DCB 5, "DEPTH"
+xDepth doCol
+ DCB SpAt, Sp0, Swap
+ DCB Minus, Slash4 ;
+ DCB Exit
+
+;-(STATE)---------------------------
+LState LINK LDepth ; Link
+ DCB 5, "STATE"
+xState PUSH {TOS}
+ LDR TOS, =VState ; Put address on TOS
+ RET
+
+;-(LATEST)--------------------------
+LLatest LINK LState ; Link
+ DCB 6, "LATEST"
+;Latest STR TOS, [DPTR]
+; INC DPTR
+; LDR TOS, =SLatest ; Put address on TOS
+ RET
+
+;-(HERE)----------------------------
+LHere LINK LLatest ; Link
+ DCB 4, "HERE"
+;Here STR TOS, [DPTR]
+; INC DPTR
+; LDR TOS, =SHere ; Put address on TOS
+ RET ; To collect the address
+
+;-(BASE)----------------------------
+LBase LINK LHere ; Link
+ DCB 4, "BASE"
+xBase PUSH {TOS}
+ LDR TOS, =VBase ; Put address on TOS
+ RET
+
+;-(msec)----------------------------
+Lmsec LINK LBase ; Link
+ DCB 4, "msec"
+msec LDR WRK, =2400
+L1msec SUBS WRK, #1 ; 1 Cycle
+ BNE L1msec ; 2 cycles (taken) 1 cycle (not taken)
+ SUBS TOS, #1 ; 1 cycle
+ BNE msec ; 2 cycles (taken) 1 cycle (not taken)
+ POP {TOS} ; Update TOS
+ RET
+
+
+;-(10usec)--------------------------
+Lusec LINK Lmsec ; Link
+ DCB 6, "10usec"
+Tusec LDR WRK, =23
+L1usec SUBS WRK, #1 ; 1 Cycle
+ BNE L1usec ; 2 cycles (taken) 1 cycle (not taken)
+ SUBS TOS, #1 ; 1 cycle
+ BNE Tusec ; 2 cycles (taken) 1 cycle (not taken)
+ POP {TOS} ; Update TOS
+ RET
+
+;-(SNAP)----------------------------; Debug helper
+LSnap LINK Lusec
+ DCB 4, "SNAP"
+xSnap PUSH {TOS}
+ESnap MOVS r0,#8
+Snap0 PUSH {TOS}
+ LSRS TOS, TOS, #28
+ CMP TOS, #0x9
+ BGT Snap1
+ ADDS TOS, #"0"
+ B Snap2
+Snap1 ADDS TOS, #("A"-0xa)
+Snap2 LDR r1,=(USART0)
+Snap3 LDR r2,[r1,#STAT]
+ LSRS r2,#3
+ BCC Snap3 ; ? ready to Xmit
+ STR TOS,[r1,#TXDAT]
+ POP {TOS}
+ LSLS TOS,#4
+ SUBS r0,#1
+ BNE Snap0 ; =0?
+ POP {TOS}
+ RET
+
+
+;-(COUNT)---------------------------(caddr -- addr,count)
+LCount LINK LSnap
+ DCB 5, "COUNT"
+xCount MOVS WRK, TOS ;
+ ADDS TOS, #1 ; Point to 1st char
+ PUSH {TOS} ; Put it on the stack
+ LDRB TOS, [WRK] ; Get length
+ RET
+
+;-(FIND)----------------------------(caddr -- caddr|xt,flag )
+; flag=0 not found, =1 immediate, =-1 not immediate
+LFind LINK LCount
+ DCB 4, "FIND" ; May be has to be recoded in high level !
+xFind LDR WRK2, =VLatest ; Get last entry pointer field
+Find1 TST WRK2, WRK2 ; More words?
+ BEQ Find4 ; No we have to leave
+ PUSH {WRK2} ; save pointer
+ ADDS WRK2, #4 ; WRK2 point to counted string
+ LDRB WRK1, [WRK2] ; Get Lenght+flag from dictionnary
+ MOVS WRK0, #0x1F ; Flag mask
+ ANDS WRK1, WRK0 ; Discard flags
+ LDRB WRK0, [TOS] ; Get length of searched string
+ CMP WRK0, WRK1 ; Are they equals ?
+ BNE Find3 ; no , we have to test next word
+
+ PUSH {TOS}
+Find1b ADDS TOS, #1 ; point to next char in input string
+ ADDS WRK2, #1 ; point to next char in dictionnary word
+ LDRB WRK0, [TOS] ; Get char in input string
+ LDRB WRK, [WRK2] ; Get char in dictionnary
+ CMP WRK0, WRK ; Are they equal
+ BNE Find2 ; no try another word
+
+ SUBS WRK1, #1 ; we start this loop with length in WRK1. It's our char counter
+ BNE Find1b ; We still have to compare more caracters
+
+ POP {TOS} ; Yes we find it
+ POP {WRK2} ; link fiel address of the word we have found
+ LDRB WRK, [WRK2, #4] ; Get flag+Length byte
+ MOVS WRK0, #Immed
+ ANDS WRK, WRK0 ; ?Immed
+ BNE Find1c ; Immed
+
+ SUBS TOS, TOS ; Not Immed
+ SUBS TOS, #1 ; flag=-1 not immed
+ B Find1d
+
+Find1c MOVS TOS, #1 ; Flag= 1 immed
+Find1d LDRB WRK, [WRK2, #4]
+ MOVS WRK1, #0x1f
+ ANDS WRK, WRK1
+ ADDS WRK2, #6 ; 4 of Lnk length, 1 name length and 1 to insure halfword align
+ ADDS WRK2, WRK
+ LSRS WRK2, #1 ; Round to a multiple
+ LSLS WRK2, #1 ; of 2
+ PUSH {WRK2} ; Xt address
+ B Find5 ; Done
+
+Find2 POP {TOS} ; Restore the address of counted string we are looking for
+Find3 POP {WRK2} ; Restore pointer of the linked chain
+ LDR WRK2,[WRK2] ; Link to next in dictionnary
+ B Find1 ; Try next one
+
+Find4 PUSH {TOS} ; Leave the c-address
+ SUBS TOS, TOS ; Clear TOS (not found)
+Find5 RET
+
+ LTORG
+
+;-(ACCEPT)--------------------------( addr, len --- len2)
+LAccept LINK LFind
+ DCB 6
+ DCB "ACCEPT"
+xAccept doCol
+ DCB Zero, ToR ; Initial count=0
+ DCB Swap ; ( len, addr --- R:0)
+Accept1
+ DCB Key ; ( len, addr, char --- R:count)
+ DCB Dup, Bl, Lt ; Is it a control character?
+ ZBranch Accept3 ; No
+
+ DCB Dup, Lit8, 8, Eq ; Is it a backspace?
+ ZBranch Accept2 ; No
+
+ DCB FromR, Dup,Zero,Eq ; Begining of line?
+ DCB Swap, ToR
+ ZBranch Accept1b ; No
+
+ DCB Lit8, 7, Emit, Drop ; Emit Bell and go to get next char
+ Branch Accept1
+
+Accept1b
+ DCB Dup,Emit, Bl, Emit, Emit
+ DCB FromR, Minus1,ToR
+ DCB Minus1
+ Branch Accept1
+Accept2
+ DCB Dup, Lit8, 13, Eq ; Is it a Carriage return
+ ZBranch Accept3 ; No
+ Branch Accept4
+Accept3
+ DCB Over, Over, Swap ; ( len , addr, char, char, addr--- r:count)
+ DCB CStore ; ( len, addr, char---R:count)
+ DCB Emit ; ( len, addr---R:count)
+ DCB Plus1 ; ( len, addr+1---R:count)
+ DCB FromR,Plus1, ToR ; ( len, addr+1---R:count+1)
+ Branch Accept1 ; go get next char
+Accept4
+ DCB TDrop, Drop, FromR ; (count)
+ DCB Cr
+ DCB Exit
+
+;-(WORD)----------------------------(char --- cstring)???????????????????????
+LWord LINK LAccept
+ DCB 4
+ DCB "WORD"
+xWord LDR WRK, =(APAD)
+ LDR WRK1, =(TIB) ; Get char at address
+ MOVS WRK2,WRK1 ; save TIB
+ LDR WRK0,=(AtoIn)
+ LDR WRK0, [WRK0]
+ ADDS WRK1, WRK0 ; Point current char
+ LDR WRK0, =(AnTib)
+ LDR WRK0, [WRK0]
+ ADDS WRK2, WRK0 ; Point end of TIB
+Word1 CMP WRK1, WRK2
+ BEQ Word3
+
+ LDRB WRK0,[WRK1] ; Get char
+ ADDS WRK1, #1 ; point to next char
+ CMP WRK0, TOS ; is it the delimiter?
+ BEQ Word1
+
+Word2 ADDS WRK, #1 ; avance 1 byte in PAD
+ STRB WRK0, [WRK]
+ CMP WRK1, WRK2
+ BEQ Word3
+
+ LDRB WRK0,[WRK1] ; Get char
+ ADDS WRK1, #1 ; point to next char
+ CMP WRK0, TOS ; is it the delimiter?
+ BNE Word2 ;
+
+Word3 MOVS WRK0, #0x32 ; Put a blank
+ STRB WRK0, [WRK, #1] ; at the end of string in pad
+ LDR TOS, =(APAD)
+ SUBS WRK, WRK, TOS ; Compute length
+ STRB WRK, [TOS] ; Put length at the beginning
+ ; of PAD
+ LDR WRK, =(TIB)
+ SUBS WRK1, WRK
+ LDR WRK, =(AtoIn)
+ STR WRK1, [WRK]
+ RET
+ LTORG
+
+;-(WORDS)----------------------------()
+LWords LINK LWord
+ DCB 5
+ DCB "WORDS"
+xWords doCol
+ DCB Lit32
+ DCD VLatest ; ??????????????????????????????????????????????????????????????????
+Words1 DCB Dup, ToR
+ DCB Lit8, 4, Plus
+ DCB Count, Lit8, 0x1f, And
+ DCB Type, Bl, Emit
+ DCB FromR, At, Dup
+ ZBranch Words2
+ Branch Words1
+Words2 DCB Drop, Cr
+ DCB Exit
+
+;-(TYPE)----------------------------(addr,number --)
+LType LINK LWords
+ DCB 4
+ DCB "TYPE"
+xType doCol
+Type1 DCB Dup ; (addr,number,number)
+ ZBranch Type2
+
+ DCB Swap, Dup, CAt ; (number, addr, char)
+ DCB Emit
+ DCB Plus1, Swap, Minus1 ; (addr+1, number-1)
+ Branch Type1
+
+Type2 DCB Drop, Drop ; ()
+ DCB Exit
+
+;-(UM+)-----------------------------(number,number -- sum,carry)
+LUMPlus LINK LType
+ DCB 3, "UM+"
+xUMPlus POP {WRK}
+ SUBS WRK2, WRK2
+ ADDS WRK,WRK,TOS
+ BCC UMPlus1
+ ADDS WRK2, #1
+UMPlus1 MOVS TOS, WRK2
+ PUSH {WRK}
+ RET
+
+;-(D+)------------------------------(double,double -- double)
+LDPlus LINK LUMPlus
+ DCB 2, "D+"
+xDPlus POP {WRK} ; low1
+ POP {WRK1} ; high2
+ POP {WRK2} ; low2
+ ADDS WRK, WRK2 ; low1 + low2
+ ADCS TOS, WRK1 ; high1+ high2 +carry
+ PUSH {WRK}
+ RET
+
+;-(D-)------------------------------(double,double -- double)
+LDMinus LINK LDPlus
+ DCB 2, "D-" ; Voir si a améliorer
+xDMinus doCol
+ DCB DNeg, DPlus
+ DCB Exit
+
+;-(DNEGATE)-------------------------(double -- -double)
+LDNeg LINK LDMinus
+ DCB 7, "DNEGATE" ; Voir si a améliorer
+xDNeg doCol
+ DCB Not, ToR, Not
+ DCB Lit8, 1, UMPlus
+ DCB FromR, Plus
+ DCB Exit
+
+;-(S>D)-----------------------------(number -- double)
+LStoD LINK LDNeg
+ DCB 3
+ DCB "S>D"
+xStoD PUSH {TOS}
+ ASRS TOS, #32
+ RET
+
+;-(U<)------------------------------(u1, u2 -- flag)
+LULess LINK LStoD
+ DCB 2
+ DCB "U<"
+xULess doCol ; Voir si a améliorer
+ DCB TDup, Xor, IsNeg
+ ZBranch ULess1
+
+ DCB Swap, Drop, IsNeg
+ Branch ULess2
+
+ULess1 DCB Minus, IsNeg
+ULess2 DCB Exit
+
+;-(U/MOD)---------------------------(ud, u -- ur , uq)
+LUmod LINK LULess
+ DCB 6
+ DCB "UM/MOD"
+; From Pygmy Forth
+; divide 64 bit r1:r2 by 32 bit TOS
+xUMSMod POP {WRK1} ; Hi reg from ud
+ POP {WRK2} ; low reg from ud
+ MOVS WRK, #32 ; Loop Index
+USMod1
+ ADDS WRK2, WRK2
+ ADCS WRK1, WRK1
+ CMP WRK1, TOS
+ BCC USMod2
+ ADDS WRK2, #1
+ SUBS WRK1, TOS
+USMod2
+ SUBS WRK, #1
+ BNE USMod1
+ PUSH {WRK1}
+ MOV TOS, WRK2
+ RET
+
+;-(LF)------------------------------; : LF 10 EMIT ;
+LLinF LINK LUmod
+ DCB 2, "LF"
+xLf doCol
+ DCB Ten, Emit
+ DCB Exit
+
+;-(CR)------------------------------; : CR 13 EMIT LF ;
+LCr LINK LLinF
+ DCB 2, "CR"
+xCr doCol
+ DCB Lit8, 0x0d, Emit, Lf
+ DCB Exit
+
+;-(BL)------------------------------
+LBl LINK LCr
+ DCB 2+Inline, "BL"
+xBl PUSH {TOS}
+ MOVS TOS, #' '
+ RET
+
+;-(SPACE)------------------------------
+LSpace LINK LBl
+ DCB 5,"SPACE"
+xSpace doCol
+ DCB Lit8, ' ', Emit
+ DCB Exit
+
+;-(SPACES)--------------------------;(n --)
+LSpaces LINK LSpace
+ DCB 6,"SPACES"
+xSpaces doCol
+Spaces1 DCB DupNZ
+ ZBranch Spaces2
+ DCB Space, Minus1
+ Branch Spaces1
+Spaces2 DCB Exit
+
+;-(DIGIT)---------------------------;(n -- char)
+LDigit LINK LSpaces
+ DCB 5, "DIGIT"
+xDigit doCol ; : Digit 9 Over < 7 And + 48 + ;
+ DCB Lit8, 9, Over, Lt
+ DCB Lit8, 7, And, Plus
+ DCB Lit8, '0', Plus
+ DCB Exit
+
+;-(FILL)----------------------------( addr,u,char -- )
+LFill LINK LDigit
+ DCB 4
+ DCB "FILL"
+xFill POP {WRK} ; Get u
+ POP {WRK2} ; Get addr
+Fill1 CMP WRK, #0
+ BEQ Fill2 ; Finish?
+ STRB TOS, [WRK2] ; Put char
+ ADDS WRK2, #1 ; addr= addr+1
+ SUBS WRK, #1 ; u = u-1
+ B Fill1 ; One more time
+Fill2 POP {TOS} ; Update TOS
+ RET
+
+;-(CODE:)---------------------------?Future??????????????
+LBCode LINK LFill
+ DCB 5+Cmponly ; CODE: CANNOT be Inline !
+ DCB "CODE:"
+xBCode ADDS IPTR, #1 ; to align at
+ LSRS IPTR, IPTR, #1 ; the next halfword
+ LSLS IPTR, IPTR, #1 ; boundary
+ ADDS IPTR, #1 ; Because of Thumb boundary
+ MOV PC, IPTR ; Jump to code itself
+ RET
+
+;-(;CODE)---------------------------?Future??????????????
+LECode LINK LBCode
+ DCB 5+Inline+Cmponly ; It MUST be inline ????
+ DCB ";CODE"
+xECode BL Here ; Where are we ? Collect address in lr
+Here MOV IPTR, lr ;
+ ADDS IPTR, #5 ; To point after the RET
+ RET
+
+;-(TOUPPER)-------------------------(char--upchar)
+LToupp LINK LECode
+ DCB 7
+ DCB "TOUPPER"
+xToupp CMP TOS, #'a'-1
+ BLE Toupp1
+ CMP TOS, #'z'+1
+ BGE Toupp1
+ SUBS TOS, #'a'-'A'
+Toupp1 RET
+
+;-(NOOP)----------------------------()
+LNoop LINK LToupp
+ DCB 4
+xNoop DCB "NOOP"
+ RET
+;-(UPPER)---------------------------(addr, count --)
+LUpper LINK LNoop
+ DCB 5
+ DCB "UPPER"
+ POP {WRK} ; Get addr
+xUpper CMP TOS, #0 ; count=0?
+ BEQ Upperx ; yes
+ LDRB WRK2, [WRK]
+ CMP WRK2, #'a'-1
+ BLE Upper3
+ CMP WRK2, #'z'+1
+ BGE Upper3
+ SUBS WRK2, #'a'-'A'
+ STRB WRK2, [WRK]
+Upper3 ADDS WRK, #1
+ SUBS TOS, #1
+ B xUpper
+Upperx POP {TOS}
+ RET
+
+;-(FALSE)---------------------------(--Fflag)
+LFalse LINK LUpper
+ DCB 5, "FALSE"
+xFalse PUSH {TOS}
+ SUBS TOS, TOS ; Put 0 in TOS
+ RET
+
+;-(TRUE)----------------------------(--Tflag)
+LTrue LINK LFalse
+ DCB 4, "TRUE"
+xTrue PUSH {TOS}
+ SUBS TOS, TOS
+ SUBS TOS, #1
+ RET
+
+;-(DECIMAL)-------------------------()
+LDecim LINK LTrue
+ DCB 7, "DECIMAL"
+xDec doCol
+ DCB Lit8, 10
+ DCB Base, Store ; Set Base to 10
+ DCB Exit
+
+;-(BIN)------------------------------()
+LBin LINK LDecim
+ DCB 3, "BIN"
+xBin doCol
+ DCB Lit8, 2
+ DCB Base, Store ; Set Base to 2
+ DCB Exit
+
+;-(HEX)------------------------------()
+LHex LINK LBin
+ DCB 3, "HEX"
+xHex doCol
+ DCB Lit8, 16
+ DCB Base, Store ; Set Base to 16
+ DCB Exit
+
+;-(HLD)-----------------------------()
+LHld LINK LHex
+ DCB 3, "HLD"
+xHld PUSH {TOS}
+ LDR TOS, =AHLD
+ RET
+;-(<#)------------------------------()
+LStrPic LINK LHld
+ DCB 2, "<#"
+xStrPic doCol
+ DCB Pad , Lit8, 127, Plus
+ DCB Hld, Store
+ DCB Exit
+
+;-(HOLD)----------------------------()
+LHold LINK LStrPic
+ DCB 4, "HOLD"
+xHold doCol
+ DCB Hld, At, Minus1
+ DCB Dup, Hld, Store, CStore
+ DCB Exit
+
+;-(#)------------------------------()
+LNumb LINK LHold
+ DCB 1, "#"
+xNumb doCol
+ DCB Base, At
+ DCB Extract
+; DCB DotS
+ DCB Hold
+ DCB Exit
+
+;-(#S)------------------------------()
+LNumStr LINK LNumb
+ DCB 2, "#S"
+xNumStr doCol
+NumStr1 DCB Numb, Dup
+ DCB IsNull
+ ZBranch NumStr1
+ DCB Exit
+
+;-(SIGN)----------------------------()
+LSign LINK LNumStr
+ DCB 4, "SIGN"
+xSign doCol
+ DCB IsNeg
+ ZBranch Sign1
+ DCB Lit8, '-', Hold
+Sign1 DCB Exit
+
+;-(#>)------------------------------()
+LEndPic LINK LSign
+ DCB 2, "#>"
+xEndPic doCol
+ DCB Drop, Hld, At
+ dcb Pad, Lit8, 127, Plus
+ DCB Over, Minus
+ DCB Exit
+
+;-(STR)-----------------------------()
+LStr LINK LEndPic
+ DCB 3, "STR"
+xStr doCol
+ DCB Dup, ToR, Abs, StrPic
+ DCB NumStr, FromR, Sign, EndPic
+ DCB Exit
+
+;-(DotR)----------------------------()
+LDotR LINK LStr
+ DCB 2, ".R"
+xDotR doCol
+ DCB ToR, Str, FromR
+ DCB Over, Minus, Spaces
+ DCB Type
+ DCB Exit
+
+;-(UdR)----------------------------()
+LUdR LINK LDotR
+ DCB 3, "U.R"
+xUDotR doCol
+ DCB ToR, StrPic, NumStr
+ DCB EndPic, FromR, Over
+ DCB Minus, Spaces, Type
+ DCB Exit
+
+;-(U.)------------------------------()
+LUDot LINK LUdR
+ DCB 2, "U."
+xUDot doCol
+ DCB StrPic, NumStr, EndPic
+ DCB Space, Type
+ DCB Exit
+
+;-(.)------------------------------()
+LDot LINK LUDot
+ DCB 1, "."
+xDot doCol
+ DCB Base, At, Lit8, 10
+ DCB Xor
+ ZBranch Dot1
+ DCB UDot
+ Branch Dot2
+Dot1 DCB Str, Space, Type
+Dot2 DCB Exit
+
+
+;-(.S)------------------------------()
+LDotS LINK LDot
+ DCB 2, ".S"
+xDotS doCol
+ DCB Depth ; (Depth)
+ DCB Sp0
+ DCB Lit8, 8 , Minus ; (depth, Sp)
+ DCB Swap ; (Sp, depth)
+DotS1 DCB Dup ; (Sp, depth, depth)
+ ZBranch DotS3 ; (sp, depth)
+
+ DCB Dup ; (sp, depth, depth)
+ DCB Lit8, 1, Eq ; (sp, depth, flag)
+ ZBranch DotS2 ; (sp, depth)
+ ; Here we collect the last element in stack which is in TOS
+ ; we need to collect it with Rot. Can be shortened...
+ DCB Rot, Snap, Cr ; (sp, depth, TOS) <<<<<<<<<<<<à remplacer par .
+ DCB MRot ; (TOS, sp, depth) Put TOS at the right place
+ Branch DotS3 ; and leave
+
+DotS2 DCB Swap, Dup, At ; (Depth,Sp,@Sp)
+ DCB Snap, Drop, Cr ; (Depth,Sp) <<<<<<<<<<<<à remplacer par .
+ DCB Lit8, 4, Minus ; (Depth,Sp)
+ DCB Swap, One, Minus ; (Sp,Depth)
+ Branch DotS1
+
+DotS3 DCB Drop, Drop ; ()
+ DCB Exit
+
+;(C,)-------------------------------(char--)
+LCComa LINK LDotS
+ DCB 2, "C,"
+xCComa doCol
+
+ DCB Exit
+
+;(H,)-------------------------------(halfword--)
+LHComa LINK LCComa
+ DCB 2, "H,"
+xHComa doCol
+ DCB Lit32
+ DCD Transit
+ DCB Dup, MRot
+; DCB Hstore
+; DCB Dup, At, CComa
+; DCB PlusOne, At, CComa
+ DCB Exit
+
+;(,)--------------------------------(word--)
+LComa LINK LHComa
+ DCB 1, ","
+xComa doCol
+ DCB Lit32
+ DCD Transit
+ DCB Dup, MRot ;(TRansaddr, word, Transaddr)
+ DCB Store ;(Transaddr)
+; DCB Dup, At, HComa
+; DCB TwoPlus, At, HComa
+ DCB Exit
+
+;(>IN)------------------------------(--address)
+LtoIn LINK LComa
+ DCB 3, ">IN"
+xtoIn PUSH {TOS}
+ LDR TOS, =AtoIn
+ RET
+
+;(PAD)-----------------------------(--address)
+LPad LINK LtoIn
+ DCB 3, "PAD"
+xPad PUSH {TOS}
+ LDR TOS, =APAD
+ RET
+;(#TIB)-----------------------------(--address)
+LnTib LINK LPad
+ DCB 4, "#TIB"
+xnTib PUSH {TOS}
+ LDR TOS, =AnTib
+ RET
+ LTORG
+;(RS0)------------------------------ Headerless
+xRS0 LDR RPTR, =Begin
+ RET
+
+;(QUIT)-----------------------------(word--)
+LQuit LINK LnTib
+ DCB 4, "QUIT"
+xQuit doCol
+ DCB Lit32
+ DCD Begin ; Set RPTR Return Stack Pointer to
+ DCB RS0 ; beginning of RAM
+ DCB False, State, Store ; Set Interpret Mode
+ ; ...........
+ DCB Exit
+
+;(ABORT)----------------------------(word--)
+LAbort LINK LQuit
+ DCB 5, "ABORT"
+ ;...................
+ DCB Exit
+
+;(INTERPRET)------------------------(word--) Still to be clean
+LInterp LINK LAbort
+ DCB 9, "INTERPRET"
+xInter doCol
+Interp DCB nTib, At ; Get # of char entered
+ DCB toIn, At ; get # of char processed
+ DCB Eq
+ ZBranch Intrp5 ; Still some char to process
+Intrp2
+ DCB Lit8, '>', Emit ; Prompt
+ DCB Lit32
+ DCD TIB
+ DCB Lit8, 50, Accept ; Refill with a new line
+; DCB DotS ; Debug <<<<<<<<<<<<<<<
+ DCB Dup, Zero, Eq ; Is it a null line?
+ ZBranch Intrp4 ; No
+Intrp3
+ DCB Drop ; Discard length
+ Branch Intrp2 ; and retry
+Intrp4
+ DCB Lit32
+ DCD AnTib
+ DCB Store ; Update #TIB
+ DCB Zero, toIn, Store ; Point to the beginning
+Intrp5
+ DCB Bl ; space is the separator
+ DCB Word ; Try to find a WORD
+ DCB Dup, CAt ; Get length
+ DCB Zero, Eq, Not ; Not a blank line?
+ ZBranch Intrp3 ; no get new one
+ ; we have a string !
+ DCB Find ; try to find it in dictionary
+ DCB Dup ; Duplicate flag from Find 0 mean not found
+ ZBranch Intrp8 ; Not a Word
+
+ DCB State, At ; c'est de <<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ DCB Eq ; la daube <<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+ ZBranch Intrp7
+ ;
+ ; compile
+ ;
+ Branch Intrp9
+Intrp7
+ DCB Execute
+ Branch Intrp10
+Intrp8 ; Traitement peut-etre nombre
+ DCB Drop, Drop
+; DCB Lit32
+; DCD Mess2, Count, Type, Type ; debug <<<<<<<<<<<<<<<<<<<<<<<
+ ; not a word may be a number
+ ;
+Intrp9
+Intrp10
+ Branch Interp
+ DCB Exit
+
+;(CallR0)---------------------------(word--)
+LCallR0 LINK LInterp
+ DCB 6
+ DCB "CallR0"
+xCallR0 doCol
+ ;...............;
+
+ DCB Exit
+
+;(DIGIT?)---------------------------(char, base --u f)
+LisDigit LINK LCallR0
+ DCB 6, "DIGIT?"
+xisDigit doCol
+ DCB ToR ;(char)
+ DCB Lit8, '0', Minus ;(num)
+ DCB Dup ;(num,num)
+ DCB Lit8, 9, Gt ;(num, flag)
+ ZBranch isDigit1
+ DCB Lit8, ('A'-'9'-1)
+ DCB Minus
+isDigit1 ;(num)
+ DCB Dup, FromR, ULess
+ DCB Exit
+
+;(CHAR)-----------------------------( -- char)
+LChar LINK LisDigit
+ DCB 4, "CHAR"
+xChar doCol
+ DCB Bl, Word, Plus1, CAt
+ DCB Exit
+
+;(EXTRACT)-----------------------------( n base -- n c)
+LExtract LINK LChar
+ DCB 7, "EXTRACT"
+xExtract doCol
+ DCB Zero, Swap, UMSMod, Swap, Digit
+ DCB Exit
+
+
+
+;(')--------------------------------( -- address)
+LTick LINK LExtract
+ DCB 1, "'"
+xTick doCol
+ DCB Bl, Word, Find, Not
+ ZBranch Tick1
+ DCB Count, Type, Bl, Emit
+ DCB Lit32
+ DCD Mess3
+ DCB Count, Type, Cr
+
+Tick1 DCB Exit
+
+;( ( )------------------------------( -- )
+LParan LINK LTick
+ DCB 1, "("
+xParan doCol
+ DCB Lit8, ")", Word
+ DCB TDrop
+ DCB Exit
+
+;(M/MOD)----------------------------( d, n -- r, q)
+LMSMod LINK LParan
+ DCB 5, "M/MOD"
+xMSMod doCol
+ DCB Dup, IsNeg, Dup, ToR
+ ZBranch UMSMod1
+
+ DCB Neg, ToR, DNeg, FromR
+UMSMod1 DCB ToR, Dup, IsNeg
+ ZBranch UMSMod2
+
+ DCB RAt, Plus
+UMSMod2 DCB FromR, UMSMod, FromR
+ ZBranch UMSMod3
+
+ DCB Swap, Neg, Swap
+UMSMod3 DCB Exit
+
+;( /MOD )---------------------------( n, n -- r, q)
+LSMod LINK LMSMod
+ DCB 4, "/MOD"
+xSMod doCol
+ DCB Over, IsNeg, Swap, MSMod
+ DCB Exit
+ LTORG
+
+;( MOD )----------------------------(n, n -- r )
+LMod LINK LSMod
+ DCB 3, "MOD"
+xMod doCol
+ DCB SMod, Drop
+ DCB Exit
+
+;( N>Tok )------------------------------( n, n -- q )
+LDiv LINK LMod
+ DCB 1, "/"
+xDiv doCol
+ DCB SMod, Swap, Drop
+ DCB Exit
+
+;( N>Tk)----------------------------( )
+LNTTk LINK LDiv
+ DCB 4, "N>Tk/"
+xNTTk doCol
+ DCB Tick ;(xt1)
+; DCB DotS
+ DCB Plus1 ; Arrh Thumb code !!!!!
+; DCB DotS
+ DCB Lit32
+ DCD TokTab
+ DCB Dup, ToR ; (xt1, TokTab)
+NTTk1 DCB TDup, At ;(xt1,TokTab,xt1,xt2)
+; DCB DotS
+ DCB Eq ;(xt1,TokT,f)
+ ZBranch NTTk2
+; DCB DotS
+ DCB FromR, Minus, Abs ;(xt1, Tok#)
+ DCB Slash4, Swap, Drop
+ Branch NTTk3
+NTTk2 DCB Lit8, 4, Minus ;(xt1, TokT-4)
+ Branch NTTk1
+NTTk3 DCB Exit
+
+;-----------------------------------
+; CONSTANTS
+Mess1 DCB 11,"ENORA-Forth"
+Mess2 DCB 5, "Error"
+Mess3 DCB 7, "Unknown"
+Mess4 DCB 3, "Ok>"
+DP0 DCD Begin
+;-----------------------------------
+NextEntry EQU .
+
+VLatest EQU LNTTk
+
+;---------End of Dictonary
+
+
+zor B zor
+
+;-(TEST)---------------------------
+;---------------------------+
+; Testing Area |
+;---------------------------+
+;xDouble doCol
+; DCB Dup, Plus ; : Double Dup + ;
+; DCB Exit
+;
+;xQuad doCol
+; DCB Double ; : Quad Double Double ;
+; DCB Double
+; DCB Exit
+; ------Test1------------OK
+; DCB 0
+;test1 DCB Lit8, 127
+;loop1 DCB Dup, Emit, Minus1
+; DCB Dup
+; ZBranch Loop12
+; Branch loop1
+;Loop12 DCB Lit8, 0xD, Emit
+; DCB Lit8, 'F', Emit
+; DCB Lit8, 'I', Emit
+; DCB Lit8, 'N', Emit
+;Loop13 Branch Loop13
+; ------End Test1 --------
+;
+;
+; ------Test3------------OK
+;test3 DCB Lit32
+; DCD 21836
+; DCB Lit8, 7
+; DCB UMSMod
+; DCB Snap
+; DCB Lit8, 0xD , Emit
+; DCB Drop, Snap
+; ------End Test3 --------
+
+; ------Test3------------OK
+;test4 DCB Lit8, 7, Double
+; DCB Lit8, 203
+; DCB Min
+; DCB Snap, Drop, Cr
+; DCB Lit8, 7, Double
+; DCB Lit8, 203
+; DCB Max
+; DCB Snap, Drop, Cr
+;l4 Branch l4
+
+; ------End Test4 --------
+;test6 DCB One
+; DCB Snap, Cr
+; DCB Digit
+; DCB Snap, Cr
+; DCB Emit
+; DCB Ten
+; DCB Snap, Cr
+; DCB Digit
+; DCB Snap, Cr
+; DCB Emit
+;Loop6 Branch Loop6
+
+;test7 DCB Lit8, 127
+; DCB Snap, Cr
+; DCB Lit8, 0
+; DCB Snap, Cr
+; DCB Lit8, 255
+; DCB Snap, Cr
+; DCB Within
+; DCB Snap, Drop, Cr
+;Loop7 Branch Loop7
+
+;test8 DCB Lit8, 3
+; DCB Double
+; DCB Snap, Cr
+; DCB Double
+; DCB Snap, Cr
+;Loop8 Branch Loop8
+;
+;test9 DCB Lit8, ">", Emit
+; DCB Lit32
+; DCD TIB+1
+; DCB Lit8, 50
+; DCB Accept
+; DCB Lit32
+; DCD TIB
+; DCB CStore
+; DCB Lit32
+; DCD TIB
+; DCB Find
+; ZBranch test91
+; DCB Execute
+
+; Branch test9
+;test91 DCB Drop
+; Branch test9
+;test10 DCB Words
+; Branch test10
+
+
+;test11 DCB Lit32
+; DCD test11c
+; DCB Lit8, 4, Plus
+; DCB Find, Swap
+; DCB Snap, Bl, Emit, Drop, Snap
+;test11b Branch test11b
+;test11c DCB 4, "TEST"
+
+
+;test12 DCB Lit8, 'a'
+;test12b DCB Dup, Toupp
+; DCB Snap, Bl, Emit, Drop, Snap, Cr
+; DCB Plus1
+; Branch test12b
+
+;test13 DCB Lit32
+; DCD TIB
+; DCB Lit8, 50, Accept
+; DCB Snap, Drop
+; Branch test13
+
+;test14 DCB Sp0, Snap, Cr
+; DCB Depth, Cr
+; DCB Snap, Drop, Cr
+;test14a Branch test14a
+
+;test15 DCB Lit8, 3, Lit8, 5
+; DCB Lit32
+; DCD xPlus
+; DCB Execute
+; DCB Snap
+;test15b Branch test15b
+
+;test16 DCB One, Lit32
+; DCD xDouble
+; DCB Minus1
+; DCB Execute
+; DCB Snap
+;test16b Branch test16b
+;
+;test17 DCB Lit32
+; DCD APAD
+; DCB Dup, Lit8, 40, Swap, CStore
+; DCB Plus1, Lit8, 40, Lit8, 'h', Fill
+; DCB Lit32
+; DCD APAD
+; DCB Count, Type
+; Branch .
+;Test17a Branch Test17a
+
+
+test18 DCB Lit8, 0, nTib, Store
+ DCB Lit8, 0, toIn, Store
+ DCB Dec
+ DCB Lit32
+ DCD Mess1
+ DCB Count, Type, Cr
+ DCB Inter
+
+;test19
+; : test begin dup if 1- else drop exit then again ;
+; DCB Lit32
+; DCD 1000000
+; DCB Lit8,'A', Emit, Cr
+;test190
+;test191 DCB Dup
+; ZBranch test192
+; DCB Minus1
+; Branch test191
+;test192 DCB Lit8,'B', Emit, Cr
+
+;test193 Branch test193
+
+; This is the token table
+; The very last one entry is token 0 preceding is token 1 ...
+; This table grow as you create new words in decreasing addresses
+
+ SPACE ((256-95)*4) ; <<<<<<<<<<<<<<<<<<<< a updater!!!!
+
+NToken EQU (TokTab-.)/4 +1
+
+wxTick DCD xTick
+wxUDot DCD xUDot
+wxDot DCD xDot
+wxEndPic DCD xEndPic
+wxSign DCD xSign
+wxNumStr DCD xNumStr
+wxStrPic DCD xStrPic
+wxStr DCD xStr
+wxAbs DCD xAbs
+wxNumb DCD xNumb
+wxHold DCD xHold
+wxExtract DCD xExtract
+wxHld DCD xHld
+wxPad DCD xPad
+wxUMSMod DCD xUMSMod
+wxMSMod DCD xMSMod
+wxSMod DCD xSMod
+wxNeg DCD xNeg
+wxRAt DCD xRAt
+wxIsNull DCD xIsNull
+wxUless DCD xULess
+wxMul DCD xMul
+wxDotS DCD xDotS
+wxInter DCD xInter
+wxnTib DCD xnTib
+wxtoIn DCD xtoIn
+wxState DCD xState
+wxRS0 DCD xRS0
+wxTrue DCD xTrue
+wxFalse DCD xFalse
+wxDNeg DCD xDNeg
+wxDPlus DCD xDPlus
+wxDMinus DCD xDMinus
+wxIsNeg DCD xIsNeg
+wxTDup DCD x2Dup
+wxUMPlus DCD xUMPlus
+wx2Drop DCD x2Drop
+wxFill DCD xFill
+wxFoursta DCD xFoursta
+wxMRot DCD xMRot
+wxRot DCD xRot
+wxDec DCD xDec
+wxBin DCD xBin
+wxBase DCD xBase
+wxToupp DCD xToupp
+wxFind DCD xFind
+wxUpper DCD xUpper
+wxCount DCD xCount
+wxType DCD xType
+wxAt DCD xAt
+wxCAt DCD xCAt
+wxWord DCD xWord
+wxWords DCD xWords
+wxCStore DCD xCStore
+wxFromR DCD xFromR
+wxStore DCD xStore
+wxSwap DCD xSwap
+wxAccept DCD xAccept
+wxKey DCD xKey
+wxBCode DCD xBCode ; Note there is no token for ;CODE
+wxTen DCD xTen
+wxTwo DCD xTwo
+wxOne DCD xOne
+wxZero DCD xZero
+wxWithin DCD xWithin
+wxToR DCD xToR
+wxDigit DCD xDigit
+wxNot DCD xNot
+wxXor DCD xXor
+wxOr DCD xOr
+wxAnd DCD xAnd
+wxEq DCD xEq
+wxLt DCD xLt
+wxGt DCD xGt
+wxOver DCD xOver
+wxMax DCD xMax
+wxMin DCD xMin
+wxCr DCD xCr
+wxBl DCD xBl
+wxSpace DCD xSpace
+wxSpaces DCD xSpaces
+wxLf DCD xLf
+wxDrop DCD xDrop
+;wxUSMod DCD xUSMod
+wxZBra DCD xZBra
+wxSlash4 DCD xSlash4
+wxDepth DCD xDepth
+wxSp0 DCD xSp0
+wxSpAt DCD xSpAt
+wxEmit DCD xEmit
+wxBra DCD xBra
+wxExit DCD xExit
+wxPlus DCD xPlus
+wxdoLit32 DCD doLit32
+wxdoLit16 DCD doLit16
+wxdoLit8 DCD doLit8
+wxExecute DCD xExec
+wxMinus DCD xMinus
+wxDupNZ DCD xDupNZ
+wxDup DCD xDup
+wxSnap DCD xSnap
+wxMinus1 DCD xMinus1
+wxPlus1
+TokTab DCD xPlus1
+
+
+ AREA |.data|, DATA
+
+Begin EQU .
+ SPACE DataStackLength
+ SPACE RAMForIAP
+ SPACE ReturnStackLength
+__initial_sp
+
+DLatest DCD 0
+Latest DCD 0
+VState DCD 0
+VBase DCD 0
+AnTib DCD 0
+AtoIn DCD 0
+Transit DCD 0
+AHLD DCD 0
+
+TIB SPACE 128
+APAD SPACE 128
+RomBuff SPACE BuffSize
+
+fin EQU .
+ END