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.
Forth.s
- Committer:
- olzeke51
- Date:
- 2015-12-06
- Revision:
- 1:d7744c74e50f
- Parent:
- 0:df922596d756
File content as of revision 1:d7744c74e50f:
;
; 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
;grz added this incluce
#include "lpc8xx.s"
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
; 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
; 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