Gary Z
/
ENORA-Forth-8xx
Important changes to repositories hosted on mbed.com
Mbed hosted mercurial repositories are deprecated and are due to be permanently deleted in July 2026.
To keep a copy of this software download the repository Zip archive or clone locally using Mercurial.
It is also possible to export all your personal repositories from the account settings page.
Fork of
ENORA-Forth
by 
Gérard Sontag
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 |
--- 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 )
--- /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