thomas/6809_forth
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
6809_forth/forth.s
Quantum 451ab143b9 Initial Commit
2024-11-24 23:42:08 -05:00

1465 lines
22 KiB
ArmAsm
Raw Blame History

ACIA_CSR equ $EC14
ACIA_DR equ $EC15
F_TRUE equ $FFFF
F_FALSE equ $0000
F_R0 equ $E7F0
F_S0 equ $E6F0
DATA
org $E000
CODE
org $F000
DATA
mul_op_1
fdb 0
mul_op_2
fdb 0
mul_result
fdb 0
CODE
acia_write
pshu A
1
lda ACIA_CSR
anda #2
beq 1B
pulu A
sta ACIA_DR
rts
acia_read
1
lda ACIA_CSR
anda #1
beq 1B
lda ACIA_DR
rts
NEXT macro
jmp __NEXT
endm
__NEXT
; Load addr of the codeword at X into Y
ldy ,X++
; Dereference codeword and jump
jmp [,Y]
PUSHRSP macro
pshs \1
endm
POPRSP macro
puls \1
endm
DOCOL
; Push old PC
PUSHRSP X
; Address of last codeword is still in Y from NEXT
; Move past codeword (Y+2)
ldb ,Y++
tfr Y,X
; Call NEXT to execute
NEXT
entry
; == Init Stack ==
; Board 1 RAM
; ldu #$7400
; lds #$7500
; Onboard RAM
ldu #F_S0
lds #F_R0
; == Init ACIA ==
; Reset
lda #$3
sta ACIA_CSR
; CLK / 16 (9600)
; 8N1
; nRTS low, no TX int
; RX int disabled
lda #$15
sta ACIA_CSR
lda #'A'
jsr acia_write
; Initialize vars
ldy #0
sty var_STATE
ldy #10
sty var_BASE
ldy #name_X
sty var_LATEST
ldy #initial_HERE
sty var_HERE
ldy #F_S0
sty var_SZ
ldx #cold_start
NEXT
cold_start
fdb QUIT
F_IMMED equ $80
F_HIDDEN equ $20
F_LENMASK equ $1F
link set 0
defword macro ; name, namelen, flags, label
align 2
name_\4
fdb link
link set name_\4
fcb \3+\2
fcc "\1"
align 2
\4
fdb DOCOL
endm
defcode macro ; name, namelen, flags, label
align 2
name_\4
fdb link
link set name_\4
fcb \3+\2
fcc "\1"
align 2
\4
fdb code_\4
code_\4
endm
defcode "DROP",4,0,"DROP"
pulu Y
NEXT
defcode "SWAP",4,0,"SWAP"
pshu X
ldx 2,U
ldy 4,U
stx 4,U
sty 2,U
pulu X
NEXT
defcode "DUP",3,0,"DUP"
ldy ,U
pshu Y
NEXT
defcode "OVER",4,0,"OVER"
ldy 2,U
pshu Y
NEXT
defcode "ROT",3,0,"ROT"
pshu X
ldx 2,U
ldy 4,U
stx 4,U
ldx 6,U
sty 6,U
stx 2,U
pulu X
NEXT
defcode "-ROT",4,0,"NROT"
pshu X
ldx 2,U
ldy 6,U
stx 6,U
ldx 4,U
sty 4,U
stx 2,U
pulu X
NEXT
defcode "2DROP",5,0,"TWODROP"
pulu Y
pulu Y
NEXT
defcode "2DUP",4,0,"TWODUP"
ldy 2,U
pshu Y
ldy 2,U
pshu Y
NEXT
defcode "2SWAP",5,0,"TWOSWAP"
pshu X
ldx 2,U
ldy 6,U
stx 6,U
ldx 2,U
ldy 8,U
stx 8,U
sty 4,U
sty 4,U
pulu X
NEXT
defcode "?DUP",4,0,"QDUP"
ldd ,U
beq 1F
pshu D
1
NEXT
defcode "1+",2,0,"INCR"
pulu D
addd #1
pshu D
NEXT
defcode "1-",2,0,"DECR"
pulu D
subd #1
pshu D
NEXT
defcode "2+",2,0,"INCR2"
pulu D
addd #2
pshu D
NEXT
defcode "2-",2,0,"DECR2"
pulu D
subd #2
pshu D
NEXT
defcode "+",1,0,"ADD"
pulu D
addd ,U
std ,U
NEXT
defcode "-",1,0,"SUB"
ldd 2,U
subd ,U
std 2,U
pulu D
NEXT
defcode "*",1,0,"MUL"
pulu Y
sty mul_op_1
pulu Y
sty mul_op_2
jsr _MUL
ldy mul_result
pshu Y
NEXT
ls8
lslb
rola
lslb
rola
lslb
rola
lslb
rola
lslb
rola
lslb
rola
lslb
rola
lslb
rola
rts
_MUL
lda mul_op_1+1 ; A = op1_L
ldb mul_op_2+1 ; B = op2_L
mul ; D = A * B
std mul_result ; res = D
lda mul_op_1+0 ; A = op1_H
ldb mul_op_2+1 ; B = op2_L
mul ; D = A*B
; D << 8...
jsr ls8
addd mul_result ; D += (D << 8)
std mul_result
lda mul_op_1+1 ; A = op1_L
ldb mul_op_2+0 ; B = op2_H
mul ; D = A*B
; D << 8...
jsr ls8
addd mul_result ; D += (D << 8)
std mul_result
rts
defcode "/MOD",4,0,"DIVMOD"
; TODO
NEXT
do_cmp_pull macro
; Operands get pulled in the wrong order :(
pulu Y
cmpy ,U
; Remove second operand, does not clobber flags
pulu Y
endm
defcode "=",1,0,"EQU"
do_cmp_pull
beq 1F
; Not Equal
ldy #F_FALSE
jmp 2F
1
; Equal
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "<>",2,0,"NEQU"
do_cmp_pull
bne 1F
; Equal
ldy #F_FALSE
jmp 2F
1
; Not Equal
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "<",1,0,"LT"
do_cmp_pull
bgt 1F
; Not less than
ldy #F_FALSE
jmp 2F
1
; Less than
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode ">",1,0,"GT"
do_cmp_pull
blt 1F
; Not greater than
ldy #F_FALSE
jmp 2F
1
; Greater than
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "<=",2,0,"LE"
do_cmp_pull
bge 1F
; Not less than
ldy #F_FALSE
jmp 2F
1
; Less than
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode ">=",2,0,"GE"
do_cmp_pull
ble 1F
; Not greater than
ldy #F_FALSE
jmp 2F
1
; Greater than
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
do_cmp0_pull MACRO
; Load into Y to get flags
ldy ,U
; Pop off of stack
pulu Y
endm
defcode "0=",2,0,"ZEQU"
do_cmp0_pull
beq 1F
; Not equals zero
ldy #F_FALSE
jmp 2F
1
; Equals zero
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "0<>",3,0,"ZNEQU"
do_cmp0_pull
bne 1F
; Equals zero
ldy #F_FALSE
jmp 2F
1
; Not equals zero
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "0<",2,0,"ZLT"
do_cmp0_pull
blt 1F
; Not less than zero
ldy #F_FALSE
jmp 2F
1
; Less than zero
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "0>",2,0,"ZGT"
do_cmp0_pull
bgt 1F
; Not greater than zero
ldy #F_FALSE
jmp 2F
1
; Greater than zero
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "0<=",3,0,"ZLE"
do_cmp0_pull
ble 1F
; Not less than zero
ldy #F_FALSE
jmp 2F
1
; Less than zero
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "0>=",3,0,"ZGE"
do_cmp0_pull
bge 1F
; Not greater than zero
ldy #F_FALSE
jmp 2F
1
; Greater than zero
ldy #F_TRUE
2
; Push result
pshu Y
NEXT
defcode "AND",3,0,"AND"
pulu A
anda 1,U
sta 1,U
pulu A
anda 1,U
sta 1,U
NEXT
defcode "OR",2,0,"OR"
pulu A
ora 1,U
sta 1,U
pulu A
ora 1,U
sta 1,U
NEXT
defcode "XOR",3,0,"XOR"
pulu A
eora 1,U
sta 1,U
pulu A
eora 1,U
sta 1,U
NEXT
defcode "INVERT",6,0,"INVERT"
COM 1,U
COM 0,U
NEXT
defcode "NEGATE",6,0,"NEGATE"
neg 1,U
bcc 1F
inc 0,U
1 ; Handle carry
neg 0,U
NEXT
defcode "EXIT",4,0,"EXIT"
POPRSP X
NEXT
defcode "LIT",3,0,"LIT"
ldy ,X++
pshu Y
NEXT
defcode "!",1,0,"STORE"
pulu Y ; Address
pulu D ; Data
std ,Y
NEXT
defcode "@",1,0,"FETCH"
pulu Y
ldy ,Y
pshu Y
NEXT
defcode "+!",2,0,"ADDSTORE"
pulu Y
pulu D
addd ,Y
std ,Y
NEXT
defcode "-!",2,0,"SUBSTORE"
pulu Y ; Address
ldd ,Y ; Current value at address
subd ,U ; Amount to subtract from stack
std ,Y
pulu D ; Pop off amount to subtract
NEXT
defcode "C!",2,0,"STOREBYTE"
pulu Y
pulu D
stb ,Y
NEXT
defcode "C@",2,0,"FETCHBYTE"
pulu Y
ldb ,Y
lda #0
pshu D
NEXT
defcode "C@C!",4,0,"CCOPY"
ldy 2,U ; Src address
lda ,Y
pulu Y ; Dst address
sta ,Y++
pshu Y ; Dst address
ldy 2,U
lda ,Y++
sty 2,U
NEXT
defcode "CMOVE",5,0,"CMOVE"
pulu D ; Length
pulu Y ; Dst address
pshu X ; Preserve PC
ldx 2,U ; Src address
1
lda ,X+
sta ,Y+
decb
bne 1B
pulu X ; Restore PC
pulu Y ; Drop src address
NEXT
defvar macro ; name, namelen, flags, label, initital
defcode \1,\2,\3,\4
ldy #var_\4
pshu Y
NEXT
DATA
align 2
var_\4
fdb \5
CODE
endm
defvar "STATE",5,0,"STATE",0
defvar "HERE",4,0,"HERE",0
defvar "LATEST",6,0,"LATEST",name_X
defvar "S0",2,0,"SZ",0
defvar "BASE",4,0,"BASE",10
defconst macro ; name, namelen, flags, label, value
defcode \1,\2,\3,\4
ldy #\5
pshu Y
NEXT
endm
defconst "R0",2,0,"RZ",F_R0
defconst "DOCOL",5,0,"__DOCOL",DOCOL
defconst "F_IMMED",7,0,"__F_IMMED",F_IMMED
defconst "F_HIDDEN",8,0,"__F_HIDDEN",F_HIDDEN
defconst "F_LENMASK",9,0,"__F_LENMASK",F_LENMASK
defcode ">R",2,0,"TOR"
pulu Y
PUSHRSP Y
NEXT
defcode "R>",2,0,"FROMR"
POPRSP Y
pshu Y
NEXT
defcode "RSP@",4,0,"RSPFETCH"
pshu S
NEXT
defcode "RSP!",4,0,"RSPSTORE"
pulu S
NEXT
defcode "RDROP",5,0,"RDROP"
puls Y
NEXT
defcode "DSP@",4,0,"DSPFETCH"
tfr U,Y
pshu Y
NEXT
defcode "DSP!",4,0,"DSPSTORE"
pulu Y
tfr Y,U
NEXT
defcode "KEY",3,0,"KEY"
jsr _KEY
tfr A,B
lda #0
pshu D
NEXT
_KEY
jsr acia_read
; Echo
jsr acia_write
rts
defcode "EMIT",4,0,"EMIT"
pulu D
tfr B,A
jsr _EMIT
NEXT
_EMIT
jsr acia_write
rts
defcode "WORD",4,0,"WORD"
jsr _WORD
pshu Y ; Address
lda #0
pshu D ; Length
NEXT
_WORD
1
; Skip spaces
jsr _KEY
; TODO: Comments
cmpa #' '
beq 1B
ldb #0
ldy #word_bufer
2
; Read in word
sta ,Y+
incb
jsr _KEY
; Break when key <= 0x20 (lazy search for newline or space)
cmpa #' '
bhi 2B
ldy #word_bufer ; Address of word_bufer in Y
; Length is in B
rts
DATA
align 2
word_bufer
rzb 32
CODE
defcode "NUMBER",6,0,"NUMBER"
pulu D ; Length
pulu Y ; Address
jsr _NUMBER
pshu Y
lda #0
pshu D ; Unparsed characers
NEXT
putc macro
pshu A
lda #\1
jsr acia_write
pulu A
endm
_NUMBER
; Zero out number buffer (steal multiply buffer)
lda #0
sta mul_op_1+0
sta mul_op_1+1
pshu B ; Save counter
ldd var_BASE
std mul_op_2
pulu B ; Restore counter
; Zero length String
tstb
beq 6F
; Check for '-'
pshu A
lda ,Y+
cmpa #'-'
bne 2F
pulu A
lda #1
pshu A
; Decrement count
decb
bne 1F
; Out of characters
pulu B ; Contains F_TRUE from above, indicating error
rts
1
pshu B ; Save counter
jsr _MUL
; Move result to operand for next loop
ldd mul_result
std mul_op_1
pulu B ; Restore counter
; Load next character into A
lda ,Y+
2
; tolower
cmpa #$60
blo 3F
anda #$DF
; Convert char to int
3
suba #'0'
blo 5F ; Invalid digit
cmpa #10
blo 4F ; Number
suba #17 ; Alpha
blo 5F ; Invalid digit
adda #10
4 ; Number
cmpa var_BASE+1
bge 5F ; Invalid digit
; Add digit
adda mul_op_1+1
sta mul_op_1+1
lda #0
adca mul_op_1+0
sta mul_op_1+0
decb ; Decrement count
bne 1B
5 ; Invalid Digit
; Negate if first character was '-'
pulu A
tsta
beq 7F
; Negate
neg mul_op_1+1
bcc 6F
inc mul_op_1+0
6 ; Handle carry
neg mul_op_1+0
7 ; Invert not needed
ldy mul_op_1
rts
defcode "FIND",4,0,"FIND"
pulu D ; Length
pulu Y ; Address
jsr _FIND
pshu Y ; Header of found word or 0
NEXT
_FIND
pshu X ; Save IP
; Length in B
; Needle in X
tfr Y,X
; Current word in Y
ldy var_LATEST
1
; Check for end of list (LATEST == 0)
beq 5F
; Compare length
lda 2,Y
anda #(F_HIDDEN | F_LENMASK) ; And hidden to make the length not match
; This useless CPU cant compare registers, use the stack
pshu B
cmpa 0,U
pulu B
bne 4F
; Do a strcmp
pshu B,X,Y ; Save lenth and string pointers
; Skip link
lda ,Y++
; Skip length
lda ,Y+
2
lda ,Y+
cmpa ,X+
bne 3F ; Not equal
decb
bne 2B
; Equal
pulu B,X,Y ; Restore stack
pulu X ; Restore IP
; Y still has current word header
rts
3
; Restore stack
pulu B,X,Y
4
; Go up a link
ldy ,Y
bra 1B
5
; Not found
ldy #0
pulu X ; Restore IP
rts
defcode ">CFA",4,0,"TCFA"
pulu Y ; Word header
jsr _TCFA
pshu Y ; Word CFA
NEXT
_TCFA
; Get length
ldb 2,Y
andb #F_LENMASK
addb #3 ; Add 3 bytes to skip link and length/flags bytes + 1 byte for alignment
; Add B to Y
pshu X
tfr Y,X
ABX
tfr X,Y
pulu X
; Align to 2 byte boundary
tfr Y,D
addb #1
adca #0
andb #~1
tfr D,Y
rts
defword ">DFA",4,0,"TDFA"
fdb TCFA
fdb INCR2
fdb EXIT
defcode "CREATE",6,0,"CREATE"
; Get args
pulu D ; Length (in B)
pulu Y ; Address of name
pshu X ; Save PC
pshu Y ; Save name address
; Store LATEST at HERE
ldy var_LATEST
ldx var_HERE
sty ,X++
pulu Y ; Restore name address
; X has HERE
; Y has name
; B has length
; Write length
stb ,X+
; Write WORD
1
lda ,Y+
sta ,X+
decb
bne 1B
; Align to 2 byte boundary
tfr X,D
addb #1
adca #0
andb #~1
; Update LATEST and HERE
ldy var_HERE
sty var_LATEST
std var_HERE
; Resetore PC
pulu X
NEXT
defcode ",",1,0,"COMMA"
pulu Y
jsr _COMMA
NEXT
_COMMA
; Save PC
pshu X
ldx var_HERE
sty ,X++
stx var_HERE
; Restore PC
pulu X
rts
defcode "[",1,F_IMMED,"LBRAC"
ldy #0
sty var_STATE
NEXT
defcode "]",1,0,"RBRAC"
ldy #1
sty var_STATE
NEXT
defword ":",1,0,"COLON"
fdb WORD
fdb CREATE
fdb __DOCOL, COMMA
fdb LATEST, FETCH, HIDDEN
fdb RBRAC
fdb EXIT
defword ";",1,F_IMMED,"SEMICOLON"
fdb LIT, EXIT, COMMA
fdb LATEST, FETCH, HIDDEN
fdb LBRAC
fdb EXIT
defcode "IMMEDIATE",9,F_IMMED,"IMMEDIATE"
ldy var_LATEST
; Toggle immediate flag
lda 2,Y
eora #F_IMMED
sta 2,Y
NEXT
defcode "HIDDEN",6,0,"HIDDEN"
pulu Y
; Toggle immediate flag
lda 2,Y
eora #F_HIDDEN
sta 2,Y
NEXT
defword "HIDE",4,0,"HIDE"
fdb WORD
fdb FIND
fdb HIDDEN
fdb EXIT
defcode "'",1,0,"TICK"
; Lazy hack to get the next XT in this word
; ONLY WORKS IN COMPILE
; Can be impl with WORD FIND >CFA
ldy ,X++
pshu Y
NEXT
defcode "BRANCH",6,0,"BRANCH"
tfr X,D
addd ,X
tfr D,X
NEXT
defcode "0BRANCH",7,0,"ZBRANCH"
do_cmp0_pull
beq code_BRANCH
lda ,X++
NEXT
defcode "LITSTRING",9,0,"LITSTRING"
; Read and skip length
ldy ,X++
; Push address and length
pshu X
pshu Y
; Skip string chars
tfr X,D
addd ,U ; Y is pushed above
addb #1
adca #0
andb #~1
tfr D,X
NEXT
defcode "TELL",4,0,"TELL"
pulu D ; Length (in B)
pulu Y ; Address
1
lda ,Y+
jsr acia_write
decb
bne 1B
NEXT
defword "QUIT",4,0,"QUIT"
fdb RZ, RSPSTORE
fdb INTERPRET
fdb BRANCH,-4
defcode "INTERPRET",9,0,"INTERPRET"
jsr _WORD ; Y = addr, B = length
lda #0
sta interpret_is_lit
pshu B,Y ; Save word
jsr _FIND
cmpy #0
beq 1F
; In the dictionary, check if immediate
; Y has word header from FIND
pulu D ; Dump saved word, clobbers B
pulu B
lda 2,Y ; Get flags
pshu A
jsr _TCFA
pulu A
; Y now has the CW of the word
anda #F_IMMED
bne 4F ; Immediate
bra 2F ; Not immediate
1
; Not a word, hopefully a literal
pulu B,Y ; Recover word
inc interpret_is_lit
jsr _NUMBER
tstb
bne 6F ; Not a number
pshu Y ; Save number for later
ldy #LIT ; Codeword to write
2
lda var_STATE+1 ; HACK: var_STATE is 16 bit but is only ever 0/1
beq 4F ; Executing
; Compiling
jsr _COMMA
lda interpret_is_lit
beq 3F
; Literal
; Pull literal off stack and comma it
pulu Y
jsr _COMMA
3
NEXT
4
; Executing
lda interpret_is_lit
bne 5F
; Not a literal, just jump to XT
jmp [,Y]
5
; Executing a literal, number was already pushed to stack so just call NEXT
NEXT
6
; Parse error
ldb #errmsgend-errmsg
ldy #errmsg
7
lda ,Y+
jsr acia_write
decb
bne 7B
NEXT
errmsg
fcc "ERR!\n"
errmsgend
DATA
align 2
interpret_is_lit
fcb 0
CODE
defcode "CHAR",4,0,"CHAR"
jsr _WORD
ldb ,Y
lda #0
pshu D
NEXT
defcode "EXECUTE",7,0,"EXECUTE"
pulu Y
jmp [,Y]
NEXT
; FORTH things
defcode ".",1,0,"DOT"
pulu D
jsr w_HEX4
NEXT
w_HEX1
anda #$F
cmpa #9
ble 1F
adda #'A' - '9' - 1
1
adda #'0'
jsr acia_write
rts
w_HEX2
pshu A
lsra
lsra
lsra
lsra
jsr w_HEX1
pulu A
jsr w_HEX1
rts
w_HEX4
jsr w_HEX2
tfr B,A
jsr w_HEX2
rts
defword "BL",2,0,"BL"
fdb LIT,32
fdb EXIT
defword "CR",2,0,"CR"
fdb LIT,10
fdb EMIT
fdb EXIT
defword "SPACE",5,0,"SPACE"
fdb LIT,32
fdb EMIT
fdb EXIT
defword "LITERAL",7,F_IMMED,"LITERAL"
fdb TICK,LIT,COMMA
fdb COMMA
fdb EXIT
defword "RECURSE",7,F_IMMED,"RECURSE"
fdb LATEST,FETCH
fdb TCFA
fdb COMMA
fdb EXIT
defword "IF",2,F_IMMED,"IF"
fdb TICK,ZBRANCH,COMMA
fdb HERE,FETCH
fdb LIT,0,COMMA
fdb EXIT
defword "THEN",4,F_IMMED,"THEN"
fdb DUP
fdb HERE,FETCH,SWAP,SUB
fdb SWAP,STORE
fdb EXIT
defword "ELSE",4,F_IMMED,"ELSE"
fdb TICK,BRANCH,COMMA
fdb HERE,FETCH
fdb LIT,0,COMMA
fdb SWAP
fdb DUP
fdb HERE,FETCH,SWAP,SUB
fdb SWAP,STORE
fdb EXIT
defword "BEGIN",5,F_IMMED,"BEGIN"
fdb HERE,FETCH
fdb EXIT
defword "UNTIL",5,F_IMMED,"UNTIL"
fdb TICK,ZBRANCH,COMMA
fdb HERE,FETCH,SUB
fdb COMMA
defword "AGAIN",5,F_IMMED,"AGAIN"
fdb TICK,BRANCH,COMMA
fdb HERE,FETCH,SUB
fdb COMMA
fdb EXIT
defword "WHILE",5,F_IMMED,"WHILE"
fdb TICK,ZBRANCH,COMMA
fdb HERE,FETCH
fdb LIT,0,COMMA
fdb EXIT
defword "REPEAT",6,F_IMMED,"REPEAT"
fdb TICK,BRANCH,COMMA
fdb SWAP
fdb HERE,FETCH,SUB,COMMA
fdb DUP
fdb HERE,FETCH,SWAP,SUB
fdb SWAP,STORE
fdb EXIT
defword "NIP",3,0,"NIP"
fdb SWAP,DROP
fdb EXIT
defword "TUCK",4,0,"TUCK"
fdb SWAP,OVER
fdb EXIT
defword "PICK",4,0,"PICK"
fdb INCR
fdb LIT,2,MUL
fdb DSPFETCH,ADD
fdb FETCH
fdb EXIT
defword ".S",2,0,"DOTS"
fdb DSPFETCH,SZ,FETCH
fdb TWODUP,LT
fdb ZBRANCH,16
fdb DECR2
fdb DUP,FETCH,DOT
fdb SPACE
fdb BRANCH,-20
fdb TWODROP
fdb EXIT
defword "ID.",3,0,"IDDOT"
fdb INCR2
fdb DUP,FETCHBYTE
fdb __F_LENMASK,AND
fdb DUP,ZGT ; BEGIN
fdb ZBRANCH,20
fdb SWAP,INCR
fdb DUP,FETCHBYTE
fdb EMIT
fdb SWAP,DECR
fdb BRANCH,-24
fdb TWODROP
fdb EXIT
defword "WORDS",5,0,"WORDS"
fdb LATEST,FETCH
fdb QDUP ; BEGIN
fdb ZBRANCH,14
fdb DUP,IDDOT
fdb SPACE
fdb FETCH
fdb BRANCH,-16
fdb CR
fdb EXIT
defword "CFA>",4,0,"CFAT"
fdb LATEST,FETCH
fdb QDUP ; BEGIN
fdb ZBRANCH,22
fdb TWODUP,SWAP
fdb LT
fdb ZBRANCH,6
fdb NIP,EXIT
fdb FETCH ; THEN
fdb BRANCH,-24
fdb DROP,LIT,0
fdb EXIT
defcode "h#",2,0,"HEXNUM"
ldy #16
sty var_BASE
NEXT
defcode "d#",2,0,"DECNUM"
ldy #10
sty var_BASE
NEXT
defword "DUMPLINE",8,0,"DUMPLINE"
fdb LIT,8
fdb DUP,ZGT ; BEGIN
fdb ZBRANCH,42
fdb SWAP,DUP,FETCH,DOT,INCR2,SWAP,DECR,SPACE
fdb DUP,LIT,4,EQU
fdb ZBRANCH,10
fdb LIT,'|',EMIT,SPACE
fdb BRANCH,-46
fdb DROP,CR
fdb EXIT
defword "DUMPLINES",9,0,"DUMPLINES"
fdb DUP,ZGT
fdb ZBRANCH,14
fdb SWAP,DUMPLINE,SWAP,DECR
fdb BRANCH,-18
fdb DROP
fdb EXIT
defword "C,",2,0,"CCOMMA"
fdb HERE,FETCH,STOREBYTE
fdb LIT,1,HERE,ADDSTORE
fdb EXIT
defword "[COMPILE]",9,F_IMMED,"BRACCOMP"
fdb WORD,FIND,TCFA,COMMA
fdb EXIT
defword "CONSTANT",8,0,"CONSTANT"
fdb WORD,CREATE
fdb __DOCOL,COMMA
fdb TICK,LIT,COMMA
fdb COMMA
fdb TICK,EXIT,COMMA
fdb EXIT
defword "ALLOT",5,0,"ALLOT"
fdb HERE,FETCH,SWAP
fdb HERE,ADDSTORE
fdb EXIT
defcode "CELLS",5,0,"CELLS"
lsl 1,U
rol 0,U
NEXT
defword "VARIABLE",8,0,"VARIABLE"
fdb LIT,1,CELLS,ALLOT
fdb WORD,CREATE
fdb __DOCOL,COMMA
fdb TICK,LIT,COMMA
fdb COMMA
fdb TICK,EXIT,COMMA
fdb EXIT
defconst "RAM1",4,0,"RAM1",$0000
defconst "RAM2",4,0,"RAM2",$2000
defconst "RAM3",4,0,"RAM3",$4000
defconst "RAM4",4,0,"RAM4",$6000
defconst "ROM1",4,0,"ROM1",$8000
defconst "ROM2",4,0,"ROM2",$A000
defconst "U28",3,0,"U28",$B000
defconst "U29",3,0,"U29",$C000
defconst "U30",3,0,"U30",$D000
defconst "W13",3,0,"W13",$E000
defconst "OUTS0",5,0,"OUTS0",$E8E0
defconst "OUTS1",5,0,"OUTS1",$E8E8
defconst "PROOFS0",7,0,"PROOFS0",$E8F0
defconst "PROOFS1",7,0,"PROOFS1",$E8F8
defconst "IRIG",4,0,"IRIG",$E900
defconst "HOLD",4,0,"HOLD",$EA00
defconst "FPI",3,0,"FPI",$EB00
defconst "CASS",4,0,"CASS",$ED00
defconst "PRNT",4,0,"PRNT",$ED04
defconst "FDME",4,0,"FDME",$EE00
defconst "INTC",4,0,"INTC",$EF00
defconst "U27",3,0,"U27",$F000
defcode "X",1,0,"X"
DATA
initial_HERE
fcb 0
CODE
; == Vectors ==
org $fff0
fdb entry
fdb entry
fdb entry
fdb entry
fdb entry
fdb entry
fdb entry
fdb entry
Reference in a new issue View git blame Copy permalink