Gérard Sontag
A forth for LPC8xxx
Hello
Forth.s
- Committer:
- Recifarium
- Date:
- 2016-05-12
- Revision:
- 2:2f8532130cca
- Parent:
- 1:1224cf3799a5
File content as of revision 2:2f8532130cca:
; 19200/8/none/1
;You must use the Keil µVision to assemble this source
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
ReturnStackLength EQU 32 * 4 ; 32 cells
DataStackLength 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 ! used by the internal interpreter
ALIAS r4, IPTR ; Instruction PoinTeR
; ALIAS r5, USER ; May be USER pointer in future
ALIAS r6, TOS ; Top Of Stack , stack managed by sp
ALIAS r7, RPTR ; Return stack PoinTeR
;-----------------------------------
; Next routine
;-----------------------------------
MACRO
$lab Next
$lab LDMIA IPTR!, {WRK} ; Get indirect address to execute
; and update Instruction pointer
LDR WRK2, [WRK] ; note that WRK point to the parameter field
BX WRK2 ; it will be used later
MEND
;-----------------------------------
; routines doCol/Con/Var
;-----------------------------------
doCol STMIA RPTR!,{IPTR} ; Save Instruction pointer to the return Stack
; & Update Return stack pointer
ADDS IPTR, WRK, #4 ; Point to parameter field
Next
doCon PUSH {TOS} ;
LDR TOS,[WRK,#4]
Next
doVar PUSH {TOS} ;
LDR TOS,[WRK,#4]
Next
;-----------------------------------
; Exit Routine (restore IPTR)
;-----------------------------------
Exit DCD xExit
xExit SUBS RPTR, RPTR, #4 ; Adjust the return stack pointer
LDR IPTR,[RPTR] ; Collect the value
Next
Lit32 DCD xLit32
xLit32 PUSH {TOS}
LDM IPTR!,{TOS} ; Nearly like next but we collect the value
Next
Zero DCD doCon
DCD 0
Ten DCD doCon
DCD 10
;-----------------------------------
;Not so usefull macro...to be change
MACRO
$lab LINK $p
$lab DCD $p
MEND
;-----------------------------------
; These macro compute the displacement
; which is store in a word
MACRO
$label Branch $target
$label DCD Bra
DCD $target
; DCD $target-.
MEND
MACRO
$label ZBranch $target
$label DCD ZBra
DCD $target
; DCD $target-.
MEND
;-----------------------------------
Reset_Handler
LDR RPTR, =Begin
BL UartConfig
SUBS TOS,TOS
LDR WRK0, =end_data
LDR WRK1, =AHERE
STR WRK0, [WRK1]
LDR IPTR, =test18
Next
test17 DCD Zero, Dot
Branch test17
test18 DCD Zero, nTib, Store
DCD Zero, toIn, Store
DCD Zero, State, Store ; Interpret mode
DCD Dec ; Set decimal mode
; DCD Esc
; DCD Lit32, 'c', Emit, Lf ; Clear screen
DCD Lit32
DCD Mess1 ; welcome message
DCD Count, Type, Cr
DCD Inter ; forever loop
;-----------------------------------
; Flag used in dictionary |
;-----------------------------------
Cmponly EQU 0x20 ; Compile only
Immed EQU 0x80 ; Indicate the word must be run immediatly
;-----------------------------------
; Dictionary start here
;-(DUP)-----------------------------(x -- x,x)
LDup LINK 0 ; First word
DCB 3, "DUP"
Dup DCD xDup
xDup PUSH {TOS} ; Push Top of stack onto the stack (sp pointing)
Next
;-----------------------------------
; All specific code for a chip
; Must be put in a separate file
; see lpc8xx.s as an example
; INCLUDE yourfavoritechip.s
INCLUDE lpc8xx.s
; INCLUDE QemuM0.s
;-(Plus1)---------------------------( n -- n+1 )
LPlus1 LINK LKey ; Link
DCB 2, "1+"
Plus1 DCD xPlus1
xPlus1 ADDS TOS, TOS, #1 ; Add 1 to TOS
Next
;-(Minus1)--------------------------( n -- n-1 )
LMinus1 LINK LPlus1 ; Link
DCB 2, "1-"
Minus1 DCD xMinus1
xMinus1 SUBS TOS, TOS, #1 ; Substract 1 to TOS
Next
;-(2DUP)----------------------------(x2,x1 -- x2,x1,x2,x1)
L2Dup LINK LMinus1 ; Link
DCB 4, "2DUP"
TDup DCD x2Dup
x2Dup PUSH {TOS} ; push x1
LDR WRK, [sp, #4] ; get x2
PUSH {WRK} ; push x2
Next ; First is still in TOS
;-(OR)------------------------------( x1 x2 -- x3 )
LOr LINK L2Dup ; Link
DCB 2,"OR"
Or DCD xOr
xOr POP {WRK} ; Get second parameter
ORRS TOS, TOS, WRK ; Or
Next
;-(AND)-----------------------------( x1 x2 -- x3 )
LAnd LINK LOr ; Link
DCB 3,"AND"
And DCD xAnd
xAnd POP {WRK} ; Get second parameter
ANDS TOS, TOS, WRK ; And
Next
;-(XOR)-----------------------------( x1 x2 -- x3 )
LXor LINK LAnd ; Link
DCB 3, "XOR"
Xor DCD xXor
xXor POP {WRK} ; Get second parameter
EORS TOS, TOS, WRK ; Xor
Next
;-(0<)------------------------------( n -- f)
LIsNeg LINK LXor ; Link
DCB 2, "0<"
IsNeg DCD xIsNeg
xIsNeg ASRS TOS, TOS, #31 ; Extend the sign True=FFFFFFFF False=00000000
Next
;-(0=)------------------------------( n -- f )
LIsNull LINK LIsNeg ; Link
DCB 2, "0="
IsNull DCD xIsNull
xIsNull MOVS TOS,TOS ; test the value
BEQ Isnull1
SUBS TOS, TOS ; False
B IsNull2
Isnull1 SUBS TOS,TOS,#1 ; True
IsNull2 Next
;-(0>)------------------------------( n -- f )
LIsPos LINK LIsNull ; Link
DCB 2, "0>"
IsPos DCD xIsPos
xIsPos MOVS TOS,TOS
LDR TOS,=0x0 ; False
BMI IsPos1
BEQ IsPos1
SUBS TOS,TOS,#1 ; True
IsPos1 Next
LTORG
;-(EXECUTE)-------------------------( xt -- )
LExec LINK LIsPos ; Link
DCB 7, "EXECUTE"
Execute DCD xExec
xExec MOVS WRK,TOS ; Get Code field address
POP {TOS} ; Update TOS
LDR WRK2,[WRK] ; Get address to be executed
BX WRK2 ; And go
;-(DROP)-----------------------------(x -- )
LDrop LINK LExec ; Link
DCB 4, "DROP"
Drop DCD xDrop
xDrop POP {TOS} ; Get previous element
Next
;-(2DROP)---------------------------( x1 x2 -- )
L2Drop LINK LDrop ; Link
DCB 5, "2DROP"
TDrop DCD x2Drop
x2Drop POP {TOS} ; Get previous element
POP {TOS} ; Get previous element
Next
;-(SWAP)----------------------------( x1 x2 -- x2 x1 )
LSwap LINK L2Drop ; Link
DCB 4, "SWAP"
Swap DCD xSwap
xSwap POP {WRK} ; Get x1
PUSH {TOS} ; Put x2
MOVS TOS,WRK ; Put x1
Next
;-(OVER)----------------------------( x1 x2 -- x1 x2 x1 )
LOver LINK LSwap ; Link
DCB 4, "OVER"
Over DCD xOver
xOver PUSH {TOS} ; Put x2
LDR TOS,[sp,#4] ; Get x1
Next
;-(ROT)-----------------------------( x1 x2 x3 -- x2 x3 x1 )
LRot LINK LOver ; Link
DCB 3, "ROT"
Rot DCD xRot
xRot POP {WRK} ; Get x2
POP {WRK2} ; Get x1
PUSH {WRK} ; Put x2
PUSH {TOS} ; Put x3
MOV TOS,WRK2 ; Put x1
Next
;-(-ROT)-----------------------------( x1 x2 x3 -- x3 x1 x2 )
LMRot LINK LRot ; Link
DCB 4, "-ROT"
MRot DCD xMRot
xMRot POP {WRK} ; Get x2
POP {WRK2} ; Get x1
PUSH {TOS} ; Put x3
PUSH {WRK2} ; Put x1
MOV TOS,WRK ; Put x2
Next
;-(NIP)-----------------------------( x1 x2 -- x2 )
LNip LINK LMRot ; Link
DCB 3, "NIP"
Nip DCD xNip
xNip POP {WRK} ; Discard x1
Next
;-(TUCK)-----------------------------( x1 x2 -- x2 x1 x2 )
LTuck LINK LNip ; Link
DCB 4, "TUCK"
Tuck DCD xTuck
xTuck POP {WRK} ; Get x1
PUSH {TOS} ; Put x2
PUSH {WRK} ; Put x1
Next
;-(+)-------------------------------( n1|u1 n2|u2 -- n3|u3 )
LPlus LINK LTuck ; Link
DCB 1, "+"
Plus DCD xPlus
xPlus POP {WRK} ; Get n1|u1
ADDS TOS, TOS, WRK ; Add n2|u2
Next
;-(-)-------------------------------( n1|u1 n2|u2 -- n3|u3 )
LMinus LINK LPlus ; Link
DCB 1, "-"
Minus DCD xMinus
xMinus POP {WRK} ; Get n1|u1
SUBS TOS, WRK, TOS ; Substract from TOS
Next
;-(2*)------------------------------
LTwosta LINK LMinus ; Link
DCB 2, "2*"
TwoStar DCD xTwoStar
xTwoStar LSLS TOS, TOS, #1 ; Shift right one bit
Next
;-(2/)------------------------------
LTwosla LINK LTwosta ; Link
DCB 2, "2/"
TwoSla DCD xTwoSla
xTwoSla ASRS TOS, TOS, #1 ; Shift left one bit
Next
;-(4*)------------------------------
LFoursta LINK LTwosla ; Link
DCB 2, "4*"
Foursta DCD xFoursta
xFoursta LSLS TOS, TOS, #2 ; Shift two bits
Next
;-(4/)------------------------------
L4Slash LINK LFoursta ; Link
DCB 2, "4/"
Slash4 DCD xSlash4
xSlash4 ASRS TOS, TOS, #2 ; Shift two bits
Next
;-(LSHIFT)--------------------------(x1,u --- x2)
LLShift LINK L4Slash ; Link
DCB 6, "LSHIFT"
LShift DCD xLShift
xLShift POP {WRK} ; Get x1
LSLS WRK, WRK, TOS ; Shift x1 u place to the left
MOVS TOS, WRK
Next
;-(RSHIFT)--------------------------(x1,u --- x2)
LRShift LINK LLShift ; Link
DCB 6, "RSHIFT"
RShift DCD xRShift
xRShift POP {WRK} ; Get x1
LSRS WRK, WRK, TOS ; Shift x1 u place to the right
MOVS TOS, WRK
Next
;-(@)-------------------------------( a -- x )
LAt LINK LRShift ; Link
DCB 1, "@"
At DCD xAt
xAt LDR TOS, [TOS] ; Get the value pointed by TOS
Next
;-(C@)------------------------------( a -- c )
LCAt LINK LAt ; Link
DCB 2, "C@"
CAt DCD xCAt
xCAt LDRB TOS, [TOS] ; Get the caracter pointed by TOS
Next
;-(H@)------------------------------( a -- h )
LHAt LINK LCAt ; Link
DCB 2, "H@"
HAt DCD xHAt
xHAt LDRH TOS, [TOS] ; Get the halfword pointed by TOS
Next
;-(!)-------------------------------(word,address --)
LStore LINK LHAt ; Link
DCB 1, "!"
Store DCD xStore
xStore POP {WRK} ; Get value to store
STR WRK, [TOS] ; Store word where TOS point to
POP {TOS} ; Update TOS
Next
;-(C!)------------------------------(char,addr--)
LCStore LINK LStore ; Link
DCB 2, "C!"
CStore DCD xCStore
xCStore POP {WRK} ; Get value to store
STRB WRK, [TOS] ; Store Character value where TOS point to
POP {TOS} ; Update TOS
Next
;-(H!)------------------------------(halfword,address --)
LHStore LINK LCStore ; Link
DCB 2 ; Length
DCB "H!"
HStore DCD xHStore
xHStore POP {WRK} ; Get value to store
STRH WRK, [TOS] ; Store Halfword where TOS point to
POP {TOS}
Next
;-(>R)------------------------------( n -- R:n)
LToR LINK LHStore ; Link
DCB 2+Cmponly,">R"
ToR DCD xToR
xToR STM RPTR!,{TOS} ; Put TOS on Nexturn stack
; & increment RPTR
POP {TOS} ; update TOS
Next
;-(R>)------------------------------(R:n -- n)
LFromR LINK LToR ; Link
DCB 2, "R>"
FromR DCD xFromR
xFromR PUSH {TOS} ; Make room
SUBS RPTR, RPTR, #4 ; Prepare to collect
LDR TOS, [RPTR] ; Collect value
Next
;-(R@)------------------------------
LRAt LINK LFromR ; Link
DCB 2, "R@"
RAt DCD xRAt
xRAt PUSH {TOS} ; Make room
MOVS TOS, RPTR ; Collect pointer
SUBS TOS, #4 ; Point to previous word
LDR TOS,[TOS] ; Get value
Next
;-(NOT)-----------------------------
LNot LINK LRAt ; Link
DCB 3, "NOT"
Not DCD xNot
xNot MVNS TOS, TOS ; move not
Next
;-(branch)-------------------------- Branch & ZBranch use word address
; Headerless
Bra DCD xBra
xBra LDR IPTR, [IPTR] ; Get the target address
Next
;-(Zbranch)-------------------------
; Headerless
ZBra DCD xZBra
xZBra TST TOS,TOS ; Update flags
POP {TOS} ;
BEQ xBra ; Take the branch if TOS = 0
ADDS IPTR, #4 ; or jump over the address
Next
;-(NEGATE)--------------------------(n -- -n)
LNegate LINK LNot ; Link
DCB 6, "NEGATE"
Neg DCD xNeg
xNeg MVNS TOS, TOS ; Move NOT signed
ADDS TOS, #1 ; 2's complement
Next
;-(ABS)-----------------------------(n -- |n|)
LAbs LINK LNegate ; Link
DCB 3, "ABS"
Abs DCD xAbs
xAbs TST TOS, TOS ; Test TOS
BPL Abs1 ; If positive do nothing
MOVS WRK, #0
SUBS TOS, WRK, TOS ; TOS = 0 - TOS
Abs1 Next
;-(MAX)-----------------------------(n1, n2 -- Max(n1,n2))
LMax LINK LAbs ; Link
DCB 3, "MAX"
Max DCD xMax
xMax POP {WRK}
CMP WRK, TOS
BLT xMax1
MOVS TOS, WRK
xMax1 Next
;-(MIN)-----------------------------(n1, n2 -- Min(n1,n2))
LMin LINK LMax ; Link
DCB 3, "MIN"
Min DCD xMin
xMin POP {WRK}
CMP WRK, TOS
BGT xMin1
MOVS TOS, WRK
xMin1 Next
;-(WITHIN)--------------------------
LWithin LINK LMin ; Link
DCB 6, "WITHIN"
Within DCD doCol
DCD Over, Minus, ToR ; : Within Over - >R - R> U< ;
DCD Minus, FromR, ULess ;
DCD Exit
;-(=)-------------------------------
LEq LINK LWithin ; Link
DCB 1, "="
Eq DCD xEq
xEq POP {WRK}
CMP WRK,TOS
LDR TOS, =0x0 ; False flag
BNE xEq1
SUBS TOS, #1 ; True
xEq1 Next
;-(<>)-------------------------------
LNEq LINK LEq ; Link
DCB 2, "<>"
NEq DCD doCol
DCD Eq, Not
DCD Exit
;-(<)-------------------------------
LLt LINK LNEq ; Link
DCB 1, "<"
Lt DCD xLt
xLt POP {WRK}
CMP WRK,TOS
LDR TOS, =0x0 ; False flag
BGE xLt1
SUBS TOS, #1 ; True
xLt1 Next
;-(>)-------------------------------
LGt LINK LLt ; Link
DCB 1, ">"
Gt DCD xGt
xGt POP {WRK}
CMP WRK,TOS
LDR TOS, =0x0 ; False flag
BLE xGt1
SUBS TOS, #1 ; True
xGt1 Next
;-(INVERT)--------------------------
LInvert LINK LGt ; Link
DCB 6, "INVERT"
Invert DCD xInvert
xInvert MVNS TOS, TOS
Next
;-(?DUP)----------------------------(n -- n,n | 0)
LDupNZ LINK LInvert ; Link
DCB 4, "?DUP"
DupNZ DCD xDupNZ
xDupNZ TST TOS, TOS ; Test TOS
BEQ DupNZ1 ; If 0 do nothing
PUSH {TOS} ; Duplicate
DupNZ1 Next
;-(*)-------------------------------
LMul LINK LDupNZ ; Link
DCB 1, "*"
Mul DCD xMul
xMul POP {WRK} ; Get 2nd Element
MULS TOS, WRK, TOS ; Multiply
Next
;-(*/)-------------------------------
LMSlash LINK LMul ; Link
DCB 2, "*/"
MSlash DCD xMSlash
xMSlash
Next
;-(+!)------------------------------(n,addr --)
LAddSto LINK LMSlash ; Link
DCB 2, "+!"
AddSto DCD xAddSto
xAddSto POP {WRK}
LDR WRK2, [TOS]
ADDS WRK, WRK2
STR WRK, [TOS]
POP {TOS}
Next
;-(-!)------------------------------
LSubSto LINK LAddSto ; Link
DCB 2, "-!"
SubSto DCD xSubSto
xSubSto POP {WRK}
LDR WRK2, [TOS]
SUBS WRK, WRK2
STR WRK, [TOS]
POP {TOS}
Next
;-(CELL)---------------------------
LCell LINK LSubSto ; Link
DCB 4, "CELL"
Cell DCD doCon
DCD 4
;-(SP0)---------------------------
LSP0 LINK LCell ; Link
DCB 3, "SP0"
Sp0 DCD xSp0
xSp0 SUBS WRK, WRK ; Cortex M0+ initial stack value @address 0
LDR WRK, [WRK]
PUSH {TOS}
MOV TOS, WRK
Next
;-(SP@)-----------------------------
LSPAt LINK LSP0 ; Link
DCB 3, "SP@"
SpAt DCD xSpAt
xSpAt MOV WRK, sp ; Collect the value before push!
PUSH {TOS}
MOV TOS, WRK ; Update
Next
;-(DEPTH)---------------------------: Depth SP@ SP0 - /4 ;
LDepth LINK LSPAt ; Link
DCB 5, "DEPTH"
Depth DCD doCol
DCD SpAt, Sp0, Swap
DCD Minus, Slash4 ;
DCD Exit
;-(STATE)---------------------------
LState LINK LDepth ; Link
DCB 5, "STATE"
State DCD doVar
DCD AState
;-(LATEST)--------------------------
LLatest LINK LState ; Link
DCB 6, "LATEST"
Latest DCD doVar
DCD DLatest
;-(HERE)----------------------------( - address)
LHere LINK LLatest ; Link
DCB 4, "HERE"
Here DCD doVar
DCD AHERE
;-(DHERE)----------------------------( - address)
LDHere LINK LHere ; Link
DCB 5, "DHERE"
DHere DCD doVar
DCD ADHERE
;-(CHERE)----------------------------( - address)
LCHere LINK LDHere ; Link
DCB 5, "CHERE"
CHere DCD doVar
DCD ACHERE
;-(BASE)----------------------------
LBase LINK LCHere ; Link
DCB 4, "BASE"
Base DCD doVar
DCD VBase
;xBase PUSH {TOS}
; LDR TOS, =VBase ; Put address on TOS
; Next
;-(msec)----------------------------
Lmsec LINK LBase ; Link
DCB 4, "msec"
msec DCD xmsec
xmsec LDR WRK, =2400
msec1 SUBS WRK, #1 ; 1 Cycle
BNE msec1 ; 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
Next
;-(10usec)--------------------------
Lusec LINK Lmsec ; Link
DCB 6, "10usec"
usec DCD xusec
xusec LDR WRK, =23
usec1 SUBS WRK, #1 ; 1 Cycle
BNE usec1 ; 2 cycles (taken) 1 cycle (not taken)
SUBS TOS, #1 ; 1 cycle
BNE xusec ; 2 cycles (taken) 1 cycle (not taken)
POP {TOS} ; Update TOS
Next
;-(SNAP)----------------------------; Debug helper when nothing work! LPC8xx centric
;LSnap LINK Lusec ; dump hex value of TOS
; 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}
; Next
;-(COUNT)---------------------------(caddr -- addr,count)
LCount LINK Lusec
DCB 5, "COUNT"
Count DCD xCount
xCount MOVS WRK, TOS ;
ADDS TOS, #1 ; Point to 1st char
PUSH {TOS} ; Put it on the stack
LDRB TOS, [WRK] ; Get length
Next
;-(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 !
Find DCD xFind
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 ; Flag mask
ANDS WRK, WRK1 ; get length
ADDS WRK2, #8 ;
ADDS WRK2, WRK
LSRS WRK2, #2 ; Round to a multiple
LSLS WRK2, #2 ; of 2
PUSH {WRK2} ; Xt address
B Find5 ; ( -- xt,1|-1)
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 Next
LTORG
;-(ACCEPT)--------------------------( addr, len --- len2)
LAccept LINK LFind
DCB 6
DCB "ACCEPT"
Accept DCD doCol
DCD Zero, ToR ; Initial count=0
DCD Swap ; ( len, addr --- R:0)
Accept1
DCD Key ; ( len, addr, char --- R:count)
DCD Dup, Bl, Lt ; Is it a control character?
ZBranch Accept3 ; No
DCD Dup, Lit32, 8, Eq ; Is it a backspace?
ZBranch Accept2 ; No
DCD FromR, Dup, Zero
DCD Eq ; Begining of line?
DCD Swap, ToR
ZBranch Accept1b ; No
DCD Lit32,7, Emit, Drop ; Emit Bell and go to get next char
Branch Accept1
Accept1b
DCD Dup,Emit, Bl, Emit, Emit
DCD FromR, Minus1,ToR
DCD Minus1
Branch Accept1
Accept2
DCD Dup, Lit32, 13 ; Is it a Carriage Nexturn
DCD Eq, Not
ZBranch Accept4 ; Yes
Accept3
DCD Over, Over, Swap ; ( len , addr, char, char, addr--- R:count)
DCD CStore ; ( len, addr, char---R:count)
DCD Emit ; ( len, addr---R:count)
DCD Plus1 ; ( len, addr+1---R:count)
DCD FromR,Plus1, ToR ; ( len, addr+1---R:count+1)
Branch Accept1 ; go get next char
Accept4
DCD TDrop, Drop, FromR ; (count)
DCD Cr
DCD Exit
;-(WORD)----------------------------(char --- cstring)
LWord LINK LAccept
DCB 4
DCB "WORD" ; May be has to be recoded in high level
Word DCD xWord
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, #' ' ; 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]
Next
LTORG
;-(WORDS)----------------------------()
LWords LINK LWord
DCB 5
DCB "WORDS"
Words DCD doCol
DCD Lit32
DCD VLatest ; ??????????????????????????????????????????????????????????????????
Words1 DCD Dup, ToR
DCD Lit32, 4, Plus
DCD Count, Lit32, 0x1f, And
DCD Type, Bl, Emit
DCD FromR, At, Dup
ZBranch Words2
Branch Words1
Words2 DCD Drop, Cr
DCD Exit
;-(TYPE)----------------------------(addr,number --)
LType LINK LWords
DCB 4
DCB "TYPE"
Type DCD doCol
Type1 DCD Dup ; (addr,number,number)
ZBranch Type2
DCD Swap, Dup, CAt ; (number, addr, char)
DCD Emit
DCD Plus1, Swap, Minus1 ; (addr+1, number-1)
Branch Type1
Type2 DCD TDrop ; ()
DCD Exit
;-(UM+)-----------------------------(number,number -- sum,carry)
LUMPlus LINK LType
DCB 3, "UM+"
UMPlus DCD xUMPlus
xUMPlus POP {WRK}
SUBS WRK2, WRK2
ADDS WRK,WRK,TOS
BCC UMPlus1
ADDS WRK2, #1
UMPlus1 MOVS TOS, WRK2
PUSH {WRK}
Next
;-(D+)------------------------------(double,double -- double)
LDPlus LINK LUMPlus
DCB 2, "D+"
DPlus DCD xDPlus
xDPlus POP {WRK} ; low1
POP {WRK1} ; high2
POP {WRK2} ; low2
ADDS WRK, WRK2 ; low1 + low2
ADCS TOS, WRK1 ; high1+ high2 +carry
PUSH {WRK}
Next
;-(D-)------------------------------(double,double -- double)
LDMinus LINK LDPlus
DCB 2, "D-"
DMinus DCD doCol
DCD DNeg, DPlus
DCD Exit
;-(DNEGATE)-------------------------(double -- -double)
LDNeg LINK LDMinus
DCB 7, "DNEGATE"
DNeg DCD xDNeg
xDNeg POP {WRK0}
SUBS WRK1, WRK1
MVNS WRK0, WRK0
MVNS TOS, TOS
ADDS WRK0, #1
ADCS TOS, WRK1
PUSH {WRK0}
Next
;-(S>D)-----------------------------(number -- double)
LStoD LINK LDNeg
DCB 3
DCB "S>D"
StoD DCD xStoD
xStoD PUSH {TOS}
ASRS TOS, #32 ; Extend sign
Next
;-(U<)------------------------------(u1, u2 -- flag)
LULess LINK LStoD
DCB 2
DCB "U<"
ULess DCD doCol
DCD TDup, Xor, IsNeg
ZBranch ULess1
DCD Swap, Drop, IsNeg
Branch ULess2
ULess1 DCD Minus, IsNeg
ULess2 DCD Exit
;-(U/MOD)---------------------------(ud, u -- ur , uq)
LUmod LINK LULess
DCB 6
DCB "UM/MOD"
UMSMod DCD xUMSMod
; 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
Next
;-(LF)------------------------------; : LF 10 EMIT ;
LLinF LINK LUmod
DCB 2, "LF"
Lf DCD doCol
DCD Ten, Emit
DCD Exit
;-(CR)------------------------------; : CR 13 EMIT LF ;
LCr LINK LLinF
DCB 2, "CR"
Cr DCD doCol
DCD Lit32, 0x0d, Emit, Lf
DCD Exit
;-(BL)------------------------------
LBl LINK LCr
DCB 2, "BL"
Bl DCD xBl
xBl PUSH {TOS}
MOVS TOS, #' '
Next
;-(Esc)------------------------------; Escape char
LEsc LINK LBl
DCB 3, "ESC"
Esc DCD doCol
DCD Lit32, 0x1b, Emit
DCD Exit
;-(SPACE)------------------------------
LSpace LINK LEsc
DCB 5,"SPACE"
Space DCD doCol
DCD Bl, Emit
DCD Exit
;-(SPACES)--------------------------;(n --)
LSpaces LINK LSpace
DCB 6,"SPACES"
Spaces DCD doCol
Spaces1 DCD DupNZ
ZBranch Spaces2
DCD Space, Minus1
Branch Spaces1
Spaces2 DCD Exit
;-(DIGIT)---------------------------;(n -- char)
LDigit LINK LSpaces
DCB 5, "DIGIT"
Digit DCD doCol ; : Digit 9 Over < 7 And + 48 + ;
DCD Lit32, 9, Over, Lt
DCD Lit32, 7, And, Plus
DCD Lit32, '0', Plus
DCD Exit
;-(FILL)----------------------------( addr,u,char -- )
LFill LINK LDigit
DCB 4
DCB "FILL"
Fill DCD xFill
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
Next
;-(CODE:)---------------------------?Future??????????????
LBCode LINK LFill
DCB 5+Cmponly ; CODE: CANNOT be Inline !
DCB "CODE:"
BCode DCD xBCode
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
Next
;-(;CODE)---------------------------?Future??????????????
LECode LINK LBCode
DCB 5+Cmponly ; It MUST be inline ????
DCB ";CODE"
ECode DCD xECode+1
xECode BL THere ; Where are we ? Collect address in lr
THere MOV IPTR, lr ;
ADDS IPTR, #5 ; To point after the RET
Next
;-(TOUPPER)-------------------------(char -- upchar)
LToupp LINK LECode
DCB 7
DCB "TOUPPER"
ToUpp DCD xToUpp
xToUpp CMP TOS, #'a'-1
BLE Toupp1
CMP TOS, #'z'+1
BGE Toupp1
SUBS TOS, #'a'-'A'
Toupp1 Next
;-(NOOP)----------------------------()
LNoop LINK LToupp
DCB 4
DCB "NOOP"
Noop DCD xNoop
xNoop Next
;-(UPPER)---------------------------(addr, count --)
LUpper LINK LNoop
DCB 5
DCB "UPPER"
Upper DCD xUpper
xUpper POP {WRK} ; Get addr
Upper1 CMP TOS, #0 ; count=0?
BEQ Upper3 ; yes
LDRB WRK2, [WRK]
CMP WRK2, #'a'-1
BLE Upper2
CMP WRK2, #'z'+1
BGE Upper2
SUBS WRK2, #'a'-'A'
STRB WRK2, [WRK]
Upper2 ADDS WRK, #1
SUBS TOS, #1
B Upper1
Upper3 POP {TOS}
Next
;xUpper doCol
;Upper1 DCB DupNZ ; (addr, count, count)
; ZBranch Upper2
; DCB Minus1, ToR
; DCB Dup, Dup, CAt
; DCB Toupp, Swap, Store
; DCB Plus1, FromR
; Branch Upper1
;Upper2 DCB TDrop, Exit ; ( )
;-(FALSE)---------------------------(--Fflag)
LFalse LINK LUpper
DCB 5, "FALSE"
False DCD doCon
DCD 0
;-(TRUE)----------------------------(--Tflag)
LTrue LINK LFalse
DCB 4, "TRUE"
True DCD doCon
DCD 0xffffffff
;-(DECIMAL)-------------------------()
LDecim LINK LTrue
DCB 7, "DECIMAL"
Dec DCD xDec
xDec MOVS WRK2, #10
B SetBase
;-(BINARY)--------------------------()
LBin LINK LDecim
DCB 6, "BINARY"
Bin DCD xBin
xBin MOVS WRK2, #2
B SetBase
;-(HEX)------------------------------()
LHex LINK LBin
DCB 3, "HEX"
Hex DCD xHex
xHex MOVS WRK2, #16
SetBase LDR WRK1, =VBase
STR WRK2, [WRK1]
Next
;-(HLD)-----------------------------()
LHld LINK LHex
DCB 3, "HLD"
Hld DCD doVar
DCD AHLD
;-(<#)------------------------------()
LStrPic LINK LHld
DCB 2, "<#"
StrPic DCD doCol
DCD Pad , Lit32, 127, Plus
DCD Hld, Store
DCD Exit
;-(HOLD)----------------------------()
LHold LINK LStrPic
DCB 4, "HOLD"
Hold DCD doCol
DCD Hld, At, Minus1
DCD Dup, Hld, Store, CStore
DCD Exit
;-(#)------------------------------()
LNumb LINK LHold
DCB 1, "#"
Numb DCD doCol
DCD Base, At
DCD Extract
DCD Hold
DCD Exit
;-(#S)------------------------------()
LNumStr LINK LNumb
DCB 2, "#S"
NumStr DCD doCol
NumStr1 DCD Numb, Dup
DCD IsNull
ZBranch NumStr1
DCD Exit
;-(SIGN)----------------------------()
LSign LINK LNumStr
DCB 4, "SIGN"
Sign DCD doCol
DCD IsNeg
ZBranch Sign1
DCD Lit32, '-', Hold
Sign1 DCD Exit
;-(#>)------------------------------()
LEndPic LINK LSign
DCB 2, "#>"
EndPic DCD doCol
DCD Drop, Hld, At
DCD Pad, Lit32, 127, Plus
DCD Over, Minus
DCD Exit
;-(STR)-----------------------------()
LStr LINK LEndPic
DCB 3, "STR"
Str DCD doCol
DCD Dup, ToR, Abs, StrPic
DCD NumStr, FromR, Sign, EndPic
DCD Exit
;-(DotR)----------------------------()
LDotR LINK LStr
DCB 2, ".R"
DotR DCD doCol
DCD ToR, Str, FromR
DCD Over, Minus, Spaces
DCD Type
DCD Exit
;-(UdR)----------------------------()
LUdR LINK LDotR
DCB 3, "U.R"
UDotR DCD doCol
DCD ToR, StrPic, NumStr
DCD EndPic, FromR, Over
DCD Minus, Spaces, Type
DCD Exit
;-(U.)------------------------------()
LUDot LINK LUdR
DCB 2, "U."
UDot DCD doCol
DCD StrPic, NumStr, EndPic
DCD Space, Type
DCD Exit
;-(.)------------------------------()
LDot LINK LUDot
DCB 1, "."
Dot DCD doCol
DCD Base, At, Ten
DCD Xor
ZBranch Dot1
DCD UDot
Branch Dot2
Dot1 DCD Str, Space, Type
Dot2 DCD Exit
;-(.S)------------------------------()
LDotS LINK LDot
DCB 2, ".S"
DotS DCD doCol
DCD Depth ; (depth)
DCD Sp0, Lit32,8, Minus ; (depth, Sp)
DCD Swap ; (Sp, depth)
DCD Dup ; (Sp, depth, depth)
ZBranch DotS3 ; Stack empty at the beginning
DotS1 DCD DupNZ ; (Sp, depth, depth)
ZBranch DotS4 ; No more in stack
; (Sp, depth)
DotS2 DCD Swap, Dup, At ; (Depth,Sp,@Sp)
DCD Dot, Cr ; (Depth,Sp)
DCD Lit32, 4, Minus ; (Depth,Sp-4)
DCD Swap, Minus1 ; (Sp-4,Depth-1)
Branch DotS1 ; next item
DotS3 DCD Drop
DCD Lit32
DCD Mess6 ; Stack empty
DCD Count, Type
DotS4 DCD Drop ; ()
DCD Exit
;(C,)-------------------------------(char--)
LCComa LINK LDotS
DCB 2, "C,"
CComa DCD doCol
;...............................
DCD Exit
;(H,)-------------------------------(halfword--)
LHComa LINK LCComa
DCB 2, "H,"
HComa DCD doCol
DCD Lit32
DCD Transit
DCD Dup, MRot
; DCD Hstore
; DCD Dup, At, CComa
; DCD PlusOne, At, CComa
DCD Exit
;(,)--------------------------------(word--)
LComa LINK LHComa
DCB 1, ","
Coma DCD doCol
DCD Lit32
DCD Transit
DCD Dup, MRot ;(TRansaddr, word, Transaddr)
DCD Store ;(Transaddr)
; DCD Dup, At, HComa
; DCD TwoPlus, At, HComa
DCD Exit
;(>IN)------------------------------(--address)
LtoIn LINK LComa
DCB 3, ">IN"
toIn DCD doVar
DCD AtoIn
;(PAD)-----------------------------(--address)
LPad LINK LtoIn
DCB 3, "PAD"
Pad DCD doVar
DCD APAD
;(#TIB)-----------------------------(--address)
LnTib LINK LPad
DCB 4, "#TIB"
nTib DCD doVar
DCD AnTib
LTORG
;(RS0)------------------------------ Headerless
RS0 DCD xRS0
xRS0 LDR RPTR, =Begin
Next
;(QUIT)-----------------------------(word--)
LQuit LINK LnTib
DCB 4, "QUIT"
Quit DCD doCol
DCD Lit32
DCD Begin ; Set RPTR Return Stack Pointer to
DCD RS0 ; beginning of RAM
DCD False, State, Store ; Set Interpret Mode
; ...........
DCD Exit
LTORG
;(ABORT)----------------------------(word--)
LAbort LINK LQuit
DCB 5, "ABORT"
;...................
DCD Exit
;(>NUMBER)--------------------------( u11 c-addr1 u12 -- u21 c-addr2 u22 )
LTNumber LINK LAbort
DCB 7, ">NUMBER"
TNbr DCD doCol
; DCD DotS ; (0,addr, n) Debug
DCD ToR ; (0,addr R:n)
DCD Dup, CAt ; (0,addr, char R:n)
DCD Dup ; (0,addr, char, char R:n)
DCD Lit32, '-'
DCD Eq
ZBranch TNumbr1
DCD Lit32, -1, MRot
; DCD DotS
DCD FromR, Minus1,ToR ; (0,-1, addr, char R: n-1)
DCD Drop, Plus1
DCD Dup, CAt ; (0,-1, addr+1, char R: n-1)
; DCD DotS
Branch TNumbr2
TNumbr1 DCD Lit32, 1, MRot ; (0,1, addr, char R:n)
TNumbr2 DCD ToR, ToR, Swap
DCD FromR, FromR
TNumbr3 DCD Base, At, isDigit ; (-1|1, cumul, addr, u,f R:n )
ZBranch TNumbr4 ; It's not a number
DCD Rot, Base, At, Mul ;
DCD Plus, Swap ; (-1|1, cumul, addr R:n )
DCD FromR, Minus1
DCD DupNZ
ZBranch TNumbr5
DCD ToR, Plus1, Dup, CAt
Branch TNumbr3
TNumbr4 DCD Drop, MRot, TDrop
DCD FromR, False
DCD Exit
TNumbr5 DCD Drop, Mul, True ;
DCD Exit
;(INTERPRET)------------------------(word--) Still to be cleaned
LInterp LINK LTNumber
DCB 9, "INTERPRET"
Inter DCD doCol
Interp DCD nTib, At ; Get # of char entered
DCD toIn, At ; Get # of char processed
DCD Eq
ZBranch Intrp5 ; Still some char to process
Intrp2
DCD Lit32
DCD Mess4
DCD Count, Type
; DCD Lit32, '>', Emit ; Prompt
DCD Lit32
DCD TIB
DCD Lit32, 50, Accept ; Refill with a new line
; DCD DotS ; Debug <<<<<<<<<<<<<<<
DCD Dup, Zero, Eq ; Is it a null line?
ZBranch Intrp4 ; No
Intrp3
DCD Drop ; Discard length
Branch Intrp2 ; and retry
Intrp4
DCD Lit32, AnTib, Store ; Update #TIB
DCD Zero, toIn, Store ; Point to the beginning
Intrp5
DCD Bl ; space is the separator
DCD Word ; Try to find a WORD
DCD Dup, CAt ; Get length
DCD Zero, Eq, Not ; Not a blank line?
ZBranch Intrp3 ; no! get new one
; here we have a string !
DCD Dup, Count
DCD Upper ; Convert to uppercase
DCD Find ; try to find it in dictionary
DCD Dup ; Duplicate flag from Find: 0 mean not found
ZBranch Intrp8 ; Not a Word may be a number
; It's in dictionary
DCD Dup
DCD Lit32, 1, Eq ; Immed?
ZBranch Intrp6
DCD DotS, Key, Drop ; Debug <<<<<<<<<<<<<<<
DCD State, At
DCD Eq ; Are we compiling?
ZBranch Intrp7 ; if not execute it
;
; compile
DCD Lit32, Mess7
DCD Count, Type
DCD Dot, Cr
DCD Key, Drop
Branch Intrp10
Intrp6
DCD Drop
Intrp7
DCD Execute ; Do the job and continue
Branch Interp
Intrp8 ; Try to convert as a number
DCD Swap, Count
DCD TNbr
ZBranch Intrp11
Intrp10
Branch Interp
Intrp11
DCD Type, Bl, Emit
DCD Lit32
DCD Mess3
DCD Count, Type, Cr
Branch Interp
;(CallR0)---------------------------(word--)
LCallR0 LINK LInterp
DCB 6
DCB "CallR0"
CallR0 DCD doCol
;...............;
DCD Exit
;(DIGIT?)---------------------------(char, base --u,f)
LisDigit LINK LCallR0
DCB 6, "DIGIT?"
isDigit DCD doCol
DCD ToR ;(char)
DCD Lit32, '0', Minus ;(num)
DCD Dup ;(num,num)
DCD Lit32, 9, Gt ;(num, flag)
ZBranch isDigit1
DCD Lit32, ('A'-'9'-1)
DCD Minus
isDigit1 ;(num)
DCD Dup, FromR, ULess
DCD Exit
;(CHAR)-----------------------------( -- char)
LChar LINK LisDigit
DCB 4, "CHAR"
Char DCD doCol
DCD Bl, Word, Plus1, CAt
DCD Exit
;(EXTRACT)--------------------------( n base -- n c)
LExtract LINK LChar
DCB 7, "EXTRACT"
Extract DCD doCol
DCD Zero, Swap, UMSMod, Swap, Digit
DCD Exit
;(')--------------------------------( -- address)
LTick LINK LExtract
DCB 1, "'"
Tick DCD doCol
DCD Bl, Word
DCD Dup, Count, Upper
DCD Find, Not
ZBranch Tick1
DCD Count, Type, Bl, Emit
DCD Lit32
DCD Mess3
DCD Count, Type, Cr
Tick1 DCD Exit
;( ( )------------------------------( -- )
LParan LINK LTick
DCB 1, "("
Paran DCD doCol
DCD Lit32, ')' , Word
DCD Drop
DCD Exit
;(M/MOD)----------------------------( d, n -- r, q)
LMSMod LINK LParan
DCB 5, "M/MOD"
MSMod DCD doCol
DCD Dup, IsNeg, Dup, ToR
ZBranch UMSMod1
DCD Neg, ToR, DNeg, FromR
UMSMod1 DCD ToR, Dup, IsNeg
ZBranch UMSMod2
DCD RAt, Plus
UMSMod2 DCD FromR, UMSMod, FromR
ZBranch UMSMod3
DCD Swap, Neg, Swap
UMSMod3 DCD Exit
;( /MOD )---------------------------( n, n -- r, q)
LSMod LINK LMSMod
DCB 4, "/MOD"
SMod DCD doCol
DCD Over, IsNeg, Swap, MSMod
DCD Exit
LTORG
;( MOD )----------------------------(n, n -- r )
LMod LINK LSMod
DCB 3, "MOD"
Mod DCD doCol
DCD SMod, Drop
DCD Exit
;( / )------------------------------( n, n -- q )
LDiv LINK LMod
DCB 1, "/"
Div DCD doCol
DCD SMod, Swap, Drop
DCD Exit
;( [ )------------------------------( )
LOBrtk LINK LDiv
DCB 1, "["
OBrtk DCD doCol
DCD False, State, Store ; Set to Interpret mode
DCD Exit
;( ] )------------------------------( )
LCBrtk LINK LOBrtk
DCB 1, "]"
CBrtk DCD doCol
DCD True, State, Store ; Set to Compile mode
DCD Exit
LTORG
;( DMP )---------------------------(addr-- )
LDump LINK LCBrtk
DCB 3,"DMP"
Dump DCD doCol
DCD Base, At, ToR ;(addr R:oldbase)
DCD Hex
DCD Lit32, -4, And ; word align
Dump2 DCD Dup,Lit32,9,DotR
DCD Dup, At ;(addr,word R:oldbase)
DCD StrPic, Numb, Numb
DCD Numb, Numb
DCD Numb, Numb
DCD Numb, Numb, EndPic
DCD Space, Type, Cr
DCD Key
DCD Lit32,0x1b, Eq, Not ; Esc key ?
ZBranch Dump3
DCD Cell, Plus
Branch Dump2
Dump3 DCD Drop
DCD FromR, Base, Store
DCD Exit
;( ALIGNED )---------------------------(addr -- w.addr)
LAligned LINK LDump
DCB 7,"ALIGNED"
Aligned DCD xAligned
xAligned ADDS TOS, #3
LSRS TOS, #2
LSLS TOS, #2
Next
;( ALIGN )---------------------------( -- )
LAlign LINK LAligned
DCB 5,"ALIGN"
Align DCD doCol
DCD Here, Dup, At, Aligned
DCD Store
DCD Exit
;( CREATE )---------------------------( -- )
LCreate LINK LAlign
DCB 6,"CREATE"
Create DCD doCol
DCD Align, Here, Latest
DCD Comma
DCD Bl, Word
DCD DotS
DCD Exit
Mess8 DCB 9,"Creating "
;( FLASH )---------------------------( -- )
LFlash LINK LCreate
DCB 5,"FLASH"
Flash DCD doCol
DCD Exit
;( RAM )---------------------------( -- )
LRam LINK LFlash
DCB 3,"RAM"
Ram DCD doCol
DCD Here, At
DCD CHere, Store
DCD Exit
;( : )---------------------------( -- )
LColon LINK LRam
DCB 1+Immed,":"
Colon DCD doCol
DCD Create
DCD CBrtk ; Set compiler state on
; DCD
DCD Exit
;( ; )---------------------------( -- )
LSemi LINK LColon
DCB 1+Immed,";"
Semi DCD doCol
DCD Lit32, Exit
DCD Comma
DCD OBrtk ; Set compiler state off
DCD Exit
;( , )---------------------------(w -- )
LComma LINK LSemi
DCB 1+Cmponly,","
Comma DCD doCol
DCD Here, At, Store
DCD Cell, Here, AddSto
DCD Exit
;( Hello )---------------------------(w -- )
LHello LINK LComma
DCB 5+Immed,"HELLO"
Hello DCD doCol
DCD Lit32, Mess9
DCD Count, Type
DCD Exit
;-----------------------------------
; CONSTANTS
Mess1 DCB 11,"ENORA-Forth"
Mess2 DCB 5, "Error"
Mess3 DCB 7, "Unknown"
Mess4 DCB 3, "Ok>"
Mess5 DCB 11,"Not numeric"
Mess6 DCB 12,"Stack empty",0x0d
Mess7 DCB 9,"Compiling "
Mess9 DCB 5,"Hello",0x0d
DP0 DCD Begin
Last DCD VLatest
Avail DCD end_data
;-----------------------------------
NextEntry EQU .
VLatest EQU LHello
;---------End of Dictionary
AREA |.data|, DATA
Begin DCD 0
SPACE ReturnStackLength
SPACE RAMForIAP
SPACE DataStackLength
__initial_sp
APAD SPACE 128
TIB SPACE 128
RomBuff SPACE BuffSize
DLatest DCD 0 ; Point to latest link field
;Latest DCD 0
AState DCD 0 ; True= Compile False= Interpret
VBase DCD 0
AnTib DCD 0
AtoIn DCD 0
Transit DCD 0
AHLD DCD 0
AHERE DCD 0 ; RAM pointer
ACHERE DCD 0 ; code pointer
ADHERE DCD 0 ; data pointer
end_data EQU .
Length EQU end_data-Begin
END