LPC8xx Forth in assembler, from a Kiel user Starting point for a Work In Progress
Fork of ENORA-Forth by
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