davex-mg-utils/dxforth.s

5313 lines
122 KiB
ArmAsm

; %help
; Davex Forth interpeter.
;
; syntax: dxforth
;
; This is a Forth system implementing the Forth 2012 Core Word Set
; a subset of the Core Extensions word set, the Exception word set,
; and select words from other word sets.
;
; Additionally, words supporting Davex and ProDOS are provided.
;
; See the full documentation (not written yet) for complete information.
; %hend
; This is a byte-addressed, direct-threaded, 16-bit Forth. The stack
; can't be on the zero page due to Davex only giving us 32 bytes there.
; so it's a bit slower than some Forths due to that.
; PSP = X register
; RSP = 6502 stack
; IP = self-modified in fetch_IP
; DLAST = xczpage+0,1 - last dictionary word defined, HBYTE=0, none
; CHERE = xczpage+2,3 - next address to be compiled
; WR = xczpage+4,5 - working register
; XR = xczpage+6,7 - working register
; YR = xczpage+8,9 - working register
; ZR = xczpage+10,11 - working register
; ZSTATE = xczpage+12,13 - compilation state
; ZBASE = xczpage+14,15 - system number base
; ZACC = xczpage+16..19 - mixed-precision multiply accumulator
; SPTMP = xcpage+20,21 - place to save X register for operations that use it
; HIMEM = SPTMP+22,23 - highest available memory address+1
; RSSVE = xczpage+24,25 - saves the 6502 stack pointer upon system entry
; IHERE = xczpage+26,27 - start of user dictionary space
; INBUF = xczpage+28,29 - location of input buffer
; TRADR = xczpage+$1E - trace address (when assembled with tracing enabled)
; ***** Options & Debugging *****
.define TRACE 0
.define TRACE_WORDS 0
; ***** Firmware *****
COut = $fded
COut1 = $fdf0
TabV = $fb5b
PrByte = $fdda
Home = $fc58
VTab = $fc22
;KeyIn = $fd1b ; do not use for davex
PrntAX = $f941
; ***** Zero Page *****
CH = $24
CV = $25
.globalzp xczpage ; davex should do this
DLAST = xczpage
CHERE = DLAST+2
WR = CHERE+2 ; working register
XR = WR+2 ; second working reg
YR = XR+2 ; for saving Y register, usually
ZR = YR+2 ; used for searching dict
ZSTATE = ZR+2 ; nonzero = compiling
ZBASE = ZSTATE+2
ZACC = ZBASE+2 ; 4 bytes
ZACC1 = ZACC
ZACC2 = ZACC1+2
SPTMP = ZACC+4 ; for primitives to save data stack ptr for certain ops
HIMEM = SPTMP+2 ; maybe for memory management
RSSAV = xczpage+$18 ; for stuff we don't re-init
IHERE = RSSAV+2 ; start of user-defined dictionary words
INBUF = IHERE+2 ; location of input buffer
TRADR = xczpage+$1E
.assert (HIMEM+2)<=RSSAV,error,"fix zpage stuff!"
; ***** Constants *****
.define PSTK_SZ $80 ; size of parameter stack, some optimizations when $80
PSTK = $AF00 ; covered by the reserve
PSTKL = PSTK
PSTKH = PSTK+PSTK_SZ
.define PAD_SIZE 128 ; (for reference, not directly used yet)
; minimum required by standard is 84
.define WORD_SIZE 35 ; minimum required by standard is 33, but
; the pictured numeric output words share
; it and is required to be
; 2*(cell size in bits=1)+2 = 34 bytes, plus
; we want a count byte at the beginning
; compiler constants
.define opJSR $20 ; JSR opcode
.define opJMP $4C ; JMP opcode
.define opRTS $60 ; RTS opcode
.define opNOP $EA ; NOP opcode
; flags for words
.define F_IMMED %01000000 ; immediate
.define F_CONLY %00100000 ; compile-only
.define F_SMUDG %00010000 ; smudged, invisible in search
; Control chars
AFF = $0C
ACR = $0D
; Non-keyboard/eval source IDs (high byte)
.define SRC_REDIR $FE ; Input redirected
.define SRC_ARG $FD ; File given on command line
; Misc
P8_ER_RNG = $FE ; range of P8 errors for exception numbers
.macro ENTER
jsr enter
.endmacro
.macro EXIT
.addr exit_next
.endmacro
.macro CODE
.addr exit_code
.endmacro
.macro NEXT
jmp next
.endmacro
; optimization for the common case where
; a native word would end with jsr pushay followed by NEXT
.macro PUSHNEXT
jmp next::fast_num
.endmacro
.macro RUN
jmp next::run
.endmacro
.macro NLIT num
.if num & $FF00
.word LIT::xt
.endif
.byte <(num) ; can't do .word because ca65 won't allow negative
.byte >(num)
.endmacro
.macro SLIT str
.local target,addr
.addr _JUMP
.addr target
addr:
.byte str
target:
NLIT addr
NLIT .strlen(str)
.endmacro
.macro CSLIT str
.local target,addr
.addr _JUMP::xt
.addr target
addr:
.byte .strlen(str)
.byte str
target:
NLIT addr
.endmacro
; dictionary macros
; Dictionary format:
; Bytes Purpose
; 2 Link to previous
; 1 flags & Name length, high bit always set
; n Name (low ASCII)
; m Code field (direct threaded, CFA is eliminated)
; ... next entry or HERE
;
print_dict .set 1
;
.macro dstart
__dstart = 0
.define l_dword __dstart
.endmacro
; define a headerless word
; fname is there so that a word can be switched back and
; forth between a headerless and normal. Flags are irrelevant
; because headerless words can't be used by the user.
.macro hword dname,fname,flags
.ifnblank flags
.out "Warning: flags used on headerless word"
.endif
.ifdef c_dword
.error .sprintf("%s definition not closed",.string(c_dword))
.endif
.ifdef c_hword
.error .sprintf("%s definition not closed",.string(c_hword))
.endif
.if print_dict
.if .const(*)
.out .concat(fname, .sprintf(" (headerless) starts at $%x", *))
.endif
.endif
.define c_hword dname
.proc dname
xt:
.if TRACE_WORDS
trace fname
.endif
.endmacro
.macro dword dname,fname,flags
.ifdef c_dword
.error .sprintf("%s definition not closed",.string(c_dword))
.endif
.ifdef c_hword
.error .sprintf("%s definition not closed",.string(c_hword))
.endif
.if print_dict
.if .const(*)
.out .concat(fname, .sprintf(" starts at $%x", *))
.endif
.endif
.define c_dword dname
.proc dname
.addr l_dword
.ifblank flags
.byte $80+.strlen(fname)
.else
.byte ($80|flags)+.strlen(fname)
.endif
.byte fname
xt:
.if TRACE_WORDS
jsr trace_word
.endif
;.if print_dict
; .out .concat(fname, .sprintf(" entry at $%x", xt))
;.endif
.endmacro
.macro dwordq dname,fname,flags
.charmap $27,$22 ; temporarily map ' -> "
dword dname,fname,flags
.charmap $27,$27 ; undo mapping
.endmacro
.macro dchain dname
.ifdef l_dword
.undefine l_dword
.endif
.define l_dword dname
.endmacro
.macro eword
.endproc
.ifdef c_dword
dchain c_dword
.undefine c_dword
.endif
.ifdef c_hword
.undefine c_hword
.endif
.endmacro
.macro dconst dname,fname,value,flags
dword dname,fname,flags
ldy #<value
lda #>value
PUSHNEXT
eword
.endmacro
.macro hconst dname,fname,value,flags
hword dname,fname,flags
ldy #<(value)
lda #>(value)
PUSHNEXT
eword
.endmacro
.macro dvar dname,fname,value,flags
dword dname,fname,flags
jsr pushda
val: .word value
eword
.endmacro
.macro hvar dname,fname,value,flags
hword dname,fname,flags
jsr pushda
val: .word value
eword
.endmacro
.macro dvalue dname,fname,value,flags
dword dname,fname,flags
jsr pushconst
val: .word value
eword
.endmacro
.macro hvalue dname,fname,value,flags
hword dname,fname,flags
jsr pushconst
val: .word value
eword
.endmacro
.macro dend
ELAST = l_dword
.endmacro
.macro trace name
.if TRACE_WORDS
jsr tr_save_regs
jsr xmess
.byte '{',name,'}',$00
jsr tr_rest_regs
.endif
.endmacro
.p02
.include "davex-mg.inc"
;DX_start dx_mg_auto_origin,$100 ; load address & top reserve
DX_start $8E00,$100 ; load address & top reserve for stack
version: DX_info $01,$12,dx_cc_any,$00
DX_ptab
DX_parm 0,t_path
DX_end_ptab
DX_desc "Forth interpreter."
DX_main
; first init the immutables
tsx
stx RSSAV ; save 6502 stack ptr
ldx #mli_read
jsr xmmgr ; get # free pages
cmp #$03 ; need at least 3 pages...
bcc nomem
tax ; work around mmgr bug
dex
txa
ldx #mli_open
jsr xmmgr
bcs nomem
sta INBUF+1
sta IHERE+1
inc IHERE+1 ; make room for input buffer
lda #$00
sta SOURCE_ID
sta SOURCE_ID+1
jsr xgetparm_n ; see if file given
sta WR+1
sty WR
ldy #$00
lda (WR),y
beq :+
lda #SRC_ARG
sta SOURCE_ID+1 ; flag initial source ID
: ldx #$00 ; init stack ptr
stx INBUF
stx IHERE
jmp _cold ; now cold-start the interpreter
nomem: jsr xmess
.byte "Not enough memory!",$0D,$00
jmp xerr
.if TRACE
.proc _dtrace
txa
pha
lda TRADR+1
jsr PrByte
lda TRADR
jsr PrByte
pla
tax
rts
.endproc
.endif
.if TRACE_WORDS
.proc trace_word
jsr tr_save_regs
tsx
pla
tay
pla
txs
sta TRADR+1
sty TRADR
; TRADR now points at the last byte of the JSR
jsr dec_tradr ; to middle byte
jsr dec_tradr ; to first byte
: jsr dec_tradr ; last byte of name, or flags+len if anon
bpl :-
and #$0F
beq anon ; anonymous
sta check
lda #'{'
jsr _emit
ldy #$00
: iny
lda (TRADR),y
cmp #' '
bcc nono
jsr _emit
nono: cpy #$00 ; self-modified
check = * - 1
bcc :-
lda #'}'
jsr _emit
jsr tr_rest_regs
rts
anon: jsr xmess
.byte "{noname}",$00
; fall-through to tr_rest_regs
.endproc
.proc tr_rest_regs
lda #$00
psave = * - 1
pha
lda #$00
asave = * - 1
ldx #$00
xsave = * - 1
ldy #$00
ysave = * - 1
plp
rts
.endproc
.proc tr_save_regs
php
sta tr_rest_regs::asave
stx tr_rest_regs::xsave
sty tr_rest_regs::ysave
pla
sta tr_rest_regs::psave
rts
.endproc
.proc dec_tradr
lda TRADR
bne :+
dec TRADR+1
: dec TRADR
ldy #$00
lda (TRADR),y
rts
.endproc
.endif
; inner interpreter entry
; pops caller from 6502 stack and initializes IP with it
; saving previous IP on 6502 stack.
.proc enter
.if TRACE
txa
pha
jsr xmess
.byte $8D,"[ENTER]",$00
jsr xcheck_wait
pla
tax
.endif
lda IP
sta WR
lda IP+1
sta WR+1
pla
sta IP
pla
sta IP+1
lda WR+1
pha
lda WR
pha
; fall-through
.endproc
; fetch and execute next instruction
.proc next
jsr fetch_IP ; fetch low byte
tay
jsr fetch_IP
.if TRACE
beq fast_num1
.else
beq fast_num
.endif
run: sta target+1
sty target
.if TRACE
sta TRADR+1
sty TRADR
txa
pha
lda #'>'
jsr _emit
jsr _dtrace
pla
tax
.endif
jmp * ; self-modified, dispatch xt
target = * - 2
.if TRACE
fast_num1:
sta TRADR+1
sty TRADR
txa
pha
lda #'^'
jsr _emit
pla
tax
lda TRADR+1
ldy TRADR
.endif
fast_num:
jsr pushay ; throw on stack
jmp next ; and immediately do next insn
.endproc
.proc fetch_IP
inc IP
bne :+
inc IP+1
:
.if TRACE
lda IP
sta TRADR
lda IP+1
sta TRADR+1
txa
pha
lda #':'
jsr _emit
jsr _dtrace
pla
tax
.endif
lda * ; self-modified
IP = * - 2
rts
.endproc
IP = fetch_IP::IP
; exit thread. restore previous IP
; and resume execution at Forth IP
.proc exit_next
.if TRACE
txa
pha
jsr xmess
.byte "[EXIT]",$8D,$00
jsr xcheck_wait
pla
tax
.endif
pla ; and restore IP of caller's caller
sta IP
pla
sta IP+1
NEXT
.endproc
; exit thread, restore previous IP
; and resume 6502 after last executed IP
.proc exit_code
ldy IP ; save IP
sty YR
lda IP+1
sta YR+1
.if TRACE
sta TRADR+1
sty TRADR
txa
pha
jsr xmess
.byte ">CODE:",$00
jsr _dtrace
pla
tax
.endif
pla ; restore previous IP
sta IP
pla
sta IP+1
lda YR+1 ; old IP on 6502 stack
pha
lda YR
pha
rts ; rts resumes execution at IP+1
.endproc
; ***** stack primitives *****
.proc peekay
jsr popay
inx
rts
.endproc
; flags reflect the high byte of the popped word
.proc popay
dex
bmi stku_err
ldy PSTKL,x
lda PSTKH,x
.if TRACE
sta TRADR+1
sty TRADR
txa
pha
lda #'/'
jsr _emit
jsr _dtrace
pla
tax
ldy PSTKL,x
lda PSTKH,x
.endif
rts
.endproc
.proc popwr
jsr popay
sta WR+1
sty WR
rts
.endproc
.proc popxr
jsr popay
sta XR+1
sty XR
rts
.endproc
; stack pop routines for davex routines
; ( d -- ) -> A(high) XY(low) = d truncated to 24 bits
; X will be saved in SPTMP
.proc popaxy
jsr popay ; high cell
sty YR+1 ; to by A later
jsr popay ; low cell
stx SPTMP
tax
lda YR+1
rts
.endproc
.proc stku_err
ldx #$00
ldy #<-4
lda #>-4
jmp _throway
.endproc
.proc stko_err
ldx #PSTK_SZ-8 ; leave enough room for ops
ldy #<-3
lda #>-3
jmp _throway
.endproc
; push AY onto stack, preserves contents of AY
.proc pushay
.if TRACE
sta TRADR+1
sty TRADR
.endif
pha
sta PSTKH,x
tya
sta PSTKL,x
pla
inx
.if PSTK_SZ=$80
bmi stko_err
.else
cpx #PSTK_SZ
bcs stko_err
.endif
.if TRACE
pha
lda #'#'
jsr _emit ; these must preserve regs 'cept A
jsr _dtrace
pla
.endif
rts
.endproc
; preserves AY
.proc pusha
.if TRACE
sta TRADR
.endif
pha
sta PSTKL,x
lda #$00
sta PSTKH,x
pla
inx
.if PSTK_SZ=$80
bmi stko_err
.else
cpx #PSTK_SZ
bcs stko_err
.endif
.if TRACE
pha
lda #$00
sta TRADR+1
lda #'#'
jsr _emit
jsr _dtrace
pla
.endif
rts
.endproc
; ***** Interpretation Helpers *****
; push word data address
; this is the default routine used by CREATE
; call via JSR, pops return stack entry, pushes data addr onto stack, and
; exits via next
.proc pushda
pla ; get low byte
clc
adc #$01
tay
pla
adc #$00 ; in case page crossed
PUSHNEXT
.endproc
; push constant
; pushes the word following the JSR onto the stack
; and exits via next, this is also used by VALUE
.proc pushconst
pla ; low byte
clc
adc #$01 ; account for RTS PC-1
sta WR
pla
adc #$00
sta WR+1
ldy #$01
lda (WR),y
pha
dey
lda (WR),y
tay
pla
PUSHNEXT
.endproc
; ***** Compilation Helpers *****
.proc cworday
pha
tya
ldy #$00
sta (CHERE),y
iny
pla
sta (CHERE),y
jsr inchere
; fall-through
.endproc
.proc inchere
inc CHERE
bne :+
inc CHERE+1
: rts
.endproc
.proc cbytea
ldy #$00
sta (CHERE),y
jmp inchere
.endproc
; ***** Math Library *****
; save X before calling any of these
; use YR and ZR for the operands, ZACC for the results
; ZACC(32)=ZR(16)*YR(16)
; adapted from https://www.llx.com/~nparker/a2/mult.html
.proc _umult
lda #0
sta ZACC+2
ldx #16
l1: lsr YR+1
ror YR
bcc l2
tay
clc
lda ZR
adc ZACC+2
sta ZACC+2
tya
adc ZR+1
l2: ror
ror ZACC+2
ror ZACC+1
ror ZACC
dex
bne l1
sta ZACC+3
rts
.endproc
; ZR rem ZACC1=ZR/YR
; ibid.
.proc _udiv
lda #0
sta ZACC1
sta ZACC1+1
ldx #16
l1: asl ZR
rol ZR+1
rol ZACC1
rol ZACC1+1
lda ZACC1
sec
sbc YR
tay
lda ZACC1+1
sbc YR+1
bcc l2
sta ZACC1+1
sty ZACC1
inc ZR
l2: dex
bne l1
rts
.endproc
; ZACC(16) rem ZR(16)=ZR(32)/YR(16)
; adapted from Garth Wilson's routines
; N=0:YR 1:YR+1 2:ZR 3:ZR+1 4:ZACC 5:ZACC+1 6:ZACC+2 7:ZACC+3
.proc _umdiv
sec
lda ZR
sbc YR
lda ZR+1
sbc YR+1
bcc :+ ; no overflow
ldy #<-11
lda #>-11
jmp _throway ; result out of range
: ldx #$11
loop: rol ZACC
rol ZACC+1
dex
bne :+
rts
: rol ZR
rol ZR+1
lda #$00
sta ZACC+3 ; carry
rol ZACC+3
sec
lda ZR
sbc YR
sta ZACC+2
lda ZR+1
sbc YR+1
tay
lda ZACC+3
sbc #$0
bcc loop
lda ZACC+2
sta ZR
sty ZR+1
bcs loop
.endproc
; ***** DICTIONARY *****
dstart
; push a compiled literal at IP on the stack
; headerless native
hword LIT,"LIT"
jsr fetch_IP
tay
jsr fetch_IP
PUSHNEXT
eword
; directly compile a cell literal from IP to (HERE)
hword COMP_LIT,"COMP_LIT"
jsr fetch_IP
tay
jsr fetch_IP
jsr cworday
NEXT
eword
; directly compile a char literal from IP to (HERE)
hword COMP_CLIT,"COMP_CLIT"
jsr fetch_IP
jsr cbytea
NEXT
eword
; Programming-Tools 15.6.2.0830
; quit intepreter ( -- )
dword BYE,"BYE"
tya
ldx RSSAV
txs
tay
lda #mli_close
jsr xmmgr ; free all mem
rts
eword
; backing value for SOURCE-ID
hvar dSOURCEID,"$SOURCE-ID",0
SOURCE_ID = dSOURCEID::val
; backing values for string buffers
hconst SBUF1,"SBUF1",filebuff3
hconst SBUF2,"SBUF2",filebuff3+256
hvar CSBUF,"CSBUF",filebuff3
; non-standard
; coldstart interpreter ( * -- )
; resets to built-in dictionary, clear stack, etc.
dword COLD,"COLD"
jmp _cold
eword
; Core 6.1.2250
; really a variable, but address is constant
dconst STATE,"STATE",ZSTATE
; non-standard
hconst DMEMTOP,"$MEMTOP",X_DX_LOAD
; non-standard
; really a variable, but address is constant
hconst DHIMEM,"$HIMEM",HIMEM
.proc _emit
ora #$80
jmp COut ; it must preserve al registers
.endproc
; Core 6.1.1320
dword EMIT,"EMIT"
jsr popay
tya
jsr _emit
NEXT
eword
; ( c-addr u -- )
; Consume c-addr and u, applying routine at (ZR), inited from AY,
; to every char of the string.
; When (ZR) is called, next char is in A. (ZR) may trash
; any registers except X, and must not touch WR and XR
; when it's called, Y=0 and XR=address of string
.proc string_op_ay
sta ZR+1
sty ZR
op: jsr popwr ; length into WR
jsr popxr ; address into XR
lda WR ; now calculate ending pos into WR
clc
adc XR
sta WR
lda WR+1
adc XR+1
sta WR+1
lp: lda WR
cmp XR
bne :+
lda WR+1
cmp XR+1
bne :+
rts
: ldy #$00 ; here in case (XR) trashes it
lda (XR),y
jsr docall
inc XR
bne :+
inc XR+1
: jmp lp
docall: jmp (ZR)
.endproc
string_op = string_op_ay::op ; user sets ZR instead
; Core 6.1.2310
dword TYPE,"TYPE"
ldy #<_emit
lda #>_emit
jsr string_op_ay
NEXT
eword
; Core 6.1.1370
; ( xt -- * )
dword EXECUTE,"EXECUTE"
jsr popay
RUN
eword
; headlerless word to implement branches
hword _JUMP,"_JUMP"
jump2: jsr fetch_IP
tay
jsr fetch_IP
; we need to be at one less than the given target
cpy #$00
bne :+
sec
sbc #$01
: dey
go: sta IP+1
sty IP
NEXT
eword
; headlerless word to implement control flow
hword _SKIP,"_SKIP"
skip2: jsr fetch_IP
jsr fetch_IP
NEXT
eword
; headerless word to implement state-smartness
; if interpreting, jumps, if compiling, skips
hword _SMART,"_SMART"
lda ZSTATE
ora ZSTATE+1
beq _JUMP::xt
bne _SKIP::xt
eword
; headlerless word to implement control flow
hword _SKIP2,"_SKIP2"
jsr fetch_IP
jsr fetch_IP
jmp _SKIP::skip2
eword
.if 0 ; may not need this
; headlerless word to implement control flow
hword _SKIPJUMP,"SKIPJUMP"
jsr fetch_IP
jsr fetch_IP
jmp _JUMP::jump2
eword
.endif
; Core 6.1.0150
; ( n -- ) compile word into dictionary
dword COMMA,","
jsr popay
jsr cworday
NEXT
eword
; Core 6.1.0860
; ( c -- ) compile char into dictionary
dword CCOMMA,"C,"
jsr popay
tya
jsr cbytea
NEXT
eword
; helper
.proc wrplus2
lda WR
clc
adc #$02
sta WR
lda WR+1
adc #$00
sta WR+1
rts
.endproc
; Core 6.1.0650
; ( adr -- n ) get number n from adr
dword FETCH,"@"
jsr popwr
fetch2: jsr fetchay
PUSHNEXT
fetchay: ldy #$01 ; need to re-use
lda (WR),y
pha
dey
lda (WR),y
tay
pla
rts
eword
; Core 6.1.0350
; ( addr -- x1 ) - store x2,x1 at addr,addr+cell
dword TWOFETCH,"2@"
jsr popwr
jsr FETCH::fetchay
jsr pushay
jsr wrplus2
jmp FETCH::fetch2
eword
; Core 6.1.0870
; ( adr - c ) get char c from adr
dword CFETCH,"C@"
jsr popwr
ldy #$00
lda (WR),y
jsr pusha
NEXT
eword
; Core 6.1.0010
; ( x addr ) - store n at addr
dword STORE,"!"
jsr popwr ; pop addr into WR
store2: jsr popay ; pop n
jsr storeay ; need to re-use
NEXT
storeay: pha ; save high byte of n
tya ; store low byte first
ldy #$00
sta (WR),y
pla ; get high byte back
iny
sta (WR),y
rts
eword
; Core 6.1.0310
; ( x1 x2 addr ) - store x2,x1 at addr,addr+cell
dword TWOSTORE,"2!"
jsr popwr
jsr popay
jsr STORE::storeay
jsr wrplus2
jmp STORE::store2
eword
; Core 6.1.0010
; ( c adr ) - store char c at addr
dword CSTORE,"C!"
jsr popwr
jsr popay
tya
ldy #$00
sta (WR),y
NEXT
eword
; Core 6.1.1290
dword DUP,"DUP"
jsr peekay
PUSHNEXT
eword
; Core 6.1.0630
dword QDUP,"?DUP"
jsr peekay
cmp #$00
bne :+
cpy #$00
bne :+
NEXT
: PUSHNEXT
eword
; Core 6.1.0580
dword PtoR,">R"
jsr popay
pha
tya
pha
NEXT
eword
; Core ext 6.2.0340
; Must be primitive
dword TWOPtoR,"2>R"
jsr _swap
jsr popay
pha
tya
pha
jmp PtoR::xt
eword
; Non-standard helper
; ( x1 .. xn n -- n | r: -- xn .. x1 )
; copy x1-xn to return stack, leave n on param stack, n <= 255
; must be primitive, note not in the same order as TWOPtoR
hword NPtoR,"N>R"
jsr popay ; get n
sty YR
sty YR+1 ; save n
cpy #$00 ; just in case
beq done
: jsr popay
pha
tya
pha
dec YR
bne :-
done: lda #$00
ldy YR+1
PUSHNEXT
eword
; Core 6.1.2060
dword RtoP,"R>"
pla
tay
pla
PUSHNEXT
eword
; Core ext 6.2.0410
; must be a primitive
dword TWORtoP,"2R>"
pla
tay
pla
jsr pushay
pla
tay
pla
jsr pushay
jsr _swap
NEXT
eword
; Non-standard helper
; ( r: -- xn .. x1 | n -- x1 .. xn n | )
; copy x1-xn to parameter stack, leave n on top of param stack, n <= 255
; must be primitive, note not in the same order as TWORtoP
hword NRtoP,"N>R"
jsr popay ; get n
sty YR
sty YR+1 ; save n
cpy #$00 ; just in case
beq done
: pla
tay
pla
jsr pushay
dec YR
bne :-
done: lda #$00
ldy YR+1
PUSHNEXT
eword
; Core 6.1.2070
dword RCOPY,"R@"
stx SPTMP
tsx
pla
tay
pla
txs
ldx SPTMP
PUSHNEXT
eword
; Non-standard
.if 0
dword RSPat,"RSP@"
stx SPTMP
tsx
txa
tay
lda #$01
ldx SPTMP
PUSHNEXT
eword
.endif
; non-standard
dword RDROP,"RDROP"
pla
pla
NEXT
eword
; non-standard helper
hword RPICK,"RPICK"
jsr popay
tya
asl
sta WR
stx SPTMP
tsx
txa
sec ; +1
adc WR
tax
lda $100,x
tay
lda $101,x
ldx SPTMP
PUSHNEXT
eword
; headerless helper
; get the 2nd entry from the return stack
hword RPLUCK,"RPLUCK"
pla
sta WR
pla
sta WR+1
pla
tay
pla
jsr pushay
lda WR+1
pha
lda WR
pha
NEXT
eword
; more complicated due to the split stack
.proc _swap
jsr popay
pha
tya
pha
jsr peekay
jsr pushay
dex
dex
pla
tay
pla
jsr pushay
inx
rts
.endproc
; Core 6.1.2260
dword SWAP,"SWAP"
jsr _swap
NEXT
eword
; Core 6.1.1260
dword DROP,"DROP"
jsr popay
NEXT
eword
.proc _over
jsr popay
jsr popay
inx ; we know there are 2 values above SP
inx
jsr pushay
rts
.endproc
; Core 6.1.1990
dword OVER,"OVER"
jsr _over
NEXT
eword
; Core ext 6.2.1930
dword NIP,"NIP"
ENTER
.addr SWAP::xt
.addr DROP::xt
EXIT
eword
; Core ext 6.2.2300
dword TUCK,"TUCK"
ENTER
.addr SWAP::xt
.addr OVER::xt
EXIT
eword
; Core 6.1.0390
dword TWODUP,"2DUP"
jsr _over
jsr _over
NEXT
eword
; Core ext 6.2.0415
; ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 )
; must be primitive
dword TWORCOPY,"2R@"
stx SPTMP ; save data stack ptr
tsx ; save 6502 stack ptr
pla ; pop x2
tay
pla
sta WR+1 ; save x2 in WR
sty WR
pla ; pop x1
tay
pla
txs ; restore 6502 stack
ldx SPTMP ; restore data stack
jsr pushay ; push x1
lda WR+1 ; get x2
ldy WR ; push x2
PUSHNEXT
eword
; Core 6.1.2160
dword ROT,"ROT"
ENTER
.addr PtoR::xt
.addr SWAP::xt
.addr RtoP::xt
.addr SWAP::xt
EXIT
eword
; Non-standard
dword NROT,"-ROT"
ENTER
.addr ROT::xt
.addr ROT::xt
EXIT
eword
; Core 6.1.0430
dword TWOSWAP,"2SWAP"
ENTER
.addr PtoR::xt
.addr NROT::xt
.addr RtoP::xt
.addr NROT::xt
EXIT
eword
; Core 6.1.0400
dword TWOOVER,"2OVER"
ENTER
.addr TWOPtoR::xt
.addr TWODUP::xt
.addr TWORtoP::xt
.addr TWOSWAP::xt
EXIT
eword
; Core 6.1.0370
dword TWODROP,"2DROP"
jsr popay
jsr popay
NEXT
eword
; Core 6.1.0250
dword ZEROLT,"0<"
jsr popay
and #$80
beq :+
lda #$ff
: tay
PUSHNEXT
eword
; Core ext 6.2.1485
dword FALSE,"FALSE"
lda #$00
tay
PUSHNEXT
eword
; Core ext 6.2.2298
dword TRUE,"TRUE"
lda #$ff
tay
PUSHNEXT
eword
; Core 6.1.0270
dword ZEROQ,"0="
jsr popay ; flags reflect A reg
bne FALSE::xt
tya
bne FALSE::xt
beq TRUE::xt ; always
eword
; Core ext 6.2.0280
dword ZEROGT,"0>"
jsr popay
bmi FALSE::xt
bne TRUE::xt
tya
bne TRUE::xt
PUSHNEXT ; 0 if we got here
eword
; Core 6.1.0530
dword EQUAL,"="
jsr _cmpcom
bne FALSE::xt
cpy WR
bne FALSE::xt
beq TRUE::xt
eword
; Core 6.1.2340
dword ULT,"U<"
jsr _cmpcom
bcc TRUE::xt
bne FALSE::xt
cpy WR
bcc TRUE::xt
bcs FALSE::xt
eword
; Core ext 6.2.2350
dword UGT,"U>"
jsr _cmpcom
bcc FALSE::xt
bne TRUE::xt
cpy WR
beq FALSE::xt
bcs TRUE::xt
bcc FALSE::xt
eword
; Core 6.1.0480
dword SLT,"<"
jsr _stest
bcc FALSE::xt
bcs TRUE::xt
eword
; Core 6.1.0540
dword SGT,">"
jsr _stest
beq FALSE::xt
bcc FALSE::xt
bcs TRUE::xt ; always
eword
; Common routines for comparisons, appearing after them
; so that we can use relative branches
; all the unsigned comparisons begin this way
; ( u1 u2 -- )
.proc _cmpcom
jsr popwr ; u2 to WR
jsr popay ; u1 to AY
cmp WR+1 ; compare u1h to A
rts
.endproc
; ( n1 n2 -- ) 16 bit signed comparison
; C and Z flags reflect the same comparison results as the 8-bit
; CMP instruction (Z means equal, C means >=
.proc _stest
jsr popxr
jsr popwr
lda WR+1
eor XR+1
bpl same ; same-sign compare, good to go
lda WR ; otherwise do unsigned compare
cmp XR ; and note that opposite-signed #s can't be equal
lda WR+1
sbc XR+1
bvs :+
eor #$80
: sec ; Make sure Z flag is cleared
rol ; move comparison result into carry
rts
same: lda WR+1
cmp XR+1
bcc done ; if less than or not equal, done
bne done
lda WR
cmp XR
done: rts
.endproc
; Core 6.1.1650
; ( -- w )
dword HERE,"HERE"
lda CHERE+1
ldy CHERE
PUSHNEXT
eword
; non-standard
; ( -- w )
dword LAST,"LAST"
lda DLAST+1
ldy DLAST
PUSHNEXT
eword
dvar OLDHERE,"OLDHERE",0
; Core 6.1.1380
dword DEXIT,"EXIT",F_CONLY
jmp exit_next
eword
; _IF <falsejump> truecode
; headerless word compiled by IF
; jumps if the top of stack is false, otherwise
; skips jump addr and continues execution
hword _IF,"_IF"
jsr popay ; flags represent A reg
bne :+
tya
bne :+
jmp _JUMP::xt
: jmp _SKIP::xt
eword
; _IFFALSE <truejump> falsecode
; jumps if the top of stack is truthy, otherwise
; skips jump addr and continues execution
hword _IFFALSE,"_IFFALSE"
jsr popay ; flags represent A reg
bne :+
tya
bne :+
jmp _SKIP::xt
: jmp _JUMP::xt
eword
; Core 6.1.1700
dword IF,"IF",F_IMMED|F_CONLY
ENTER
.addr COMP_LIT::xt
.addr _IF::xt ; compile _IF
.addr HERE::xt ; save to resolve later
.addr COMP_LIT::xt
.addr controlmm ; compile unresolved
EXIT
eword
; Core 6.1.1310
; ( orig1 -- orig2 )
dword ELSE,"ELSE",F_IMMED|F_CONLY
ENTER
.addr COMP_LIT::xt
.addr _JUMP::xt ; compile JUMP
.addr HERE::xt ; (o1 -- o1 o2 )
.addr COMP_LIT::xt
.addr controlmm ; compile unresolved
.addr SWAP::xt ; (o1 o2 -- o2 o1 )
.addr HERE::xt ; (o2 o1 -- o2 o1 addr )
.addr SWAP::xt ; (o2 o1 addr -- o2 addr o1 )
.addr STORE::xt ; (o2 o1 addr -- o2 ) resolve IF
EXIT
eword
; Core 6.1.2270
; (orig -- )
dword THEN,"THEN",F_IMMED|F_CONLY
ENTER
.addr HERE::xt ; ( o1 -- o1 addr )
.addr SWAP::xt ; ( o1 addr -- addr o1 )
.addr STORE::xt ; ( o1 addr -- )
EXIT
eword
; Core 6.1.0760
dword BEGIN,"BEGIN",F_IMMED|F_CONLY
ENTER
.addr HERE::xt
EXIT
eword
; Core 6.1.2430
; ( C: dest -- orig dest )
dword WHILE,"WHILE",F_IMMED|F_CONLY
ENTER
.addr COMP_LIT::xt ; compile IF
.addr _IF::xt
.addr HERE::xt ; orig = new unresolved
.addr SWAP::xt ; underneath top
.addr COMP_LIT::xt ; compile unresolved
.addr controlmm
EXIT
eword
; Core 6.1.2390
dword UNTIL,"UNTIL",F_IMMED|F_CONLY
ENTER
.addr COMP_LIT::xt
.addr _IF::xt ; compile
.addr COMMA::xt ; compile false branch destination
EXIT
eword
; Core 6.1.2140
; ( C: orig dest -- )
dword REPEAT,"REPEAT",F_IMMED|F_CONLY
ENTER
.addr COMP_LIT::xt
.addr _JUMP::xt
.addr COMMA::xt ; compile _JUMP dest
.addr HERE::xt ; ( C: orig -- orig here )
.addr SWAP::xt ; ( ... -- here orig )
.addr STORE::xt ; resolve orig
EXIT
eword
; Core ext 6.2.0700
dword AGAIN,"AGAIN",F_IMMED|F_CONLY
ENTER
.addr COMP_LIT::xt
.addr _JUMP::xt
.addr COMMA::xt
EXIT
eword
; Core 6.1.0750
; really a variable, but the address of the var is constant
dconst BASE,"BASE",ZBASE
; Core ext 6.2.1660
dword HEX,"HEX"
ldy #<16
lda #>16
sty ZBASE
sta ZBASE+1
NEXT
eword
; Core 6.1.1170
dword DECIMAL,"DECIMAL"
ldy #<10
lda #>10
sty ZBASE
sta ZBASE+1
NEXT
eword
.if 0
; non-standard
dword OCTAL,"OCTAL"
ldy #<8
lda #>8
sty ZBASE
sta ZBASE+1
NEXT
eword
.endif
.if 0
; non-standard
dword BINARY,"BINARY"
ldy #<2
lda #>2
sty ZBASE
sta ZBASE+1
NEXT
eword
.endif
.proc _invertay
pha
tya
eor #$FF
tay
pla
eor #$FF
rts
.endproc
; Core 6.1.1720
; optimized for space
dword INVERT,"INVERT"
jsr popay
jsr _invertay
PUSHNEXT
eword
.proc _negateay
pha
tya
eor #$FF
clc
adc #$01
tay
pla
eor #$FF
adc #$00
rts
.endproc
; Core 6.1.1910
; optimized for space
dword NEGATE,"NEGATE"
jsr popay
jsr _negateay
PUSHNEXT
eword
; Non-standard
; ( d f -- d' ) if f < 0 then negate
hword QNEGATE,"?NEGATE"
jsr popay
and #$80
beq :+
jmp NEGATE::xt
: NEXT
eword
; Core 6.1.0690
dword ABS,"ABS"
lda PSTKH-1,x
bmi NEGATE::xt
NEXT
eword
; Double-Number 8.6.1.1230
dword DNEGATE,"DNEGATE"
jsr popay ; high cell
pha
tya
pha
jsr popay ; low cell
jsr _negateay
php
jsr pushay
plp
pla
eor #$FF
adc #$00
tay
pla
eor #$FF
adc #$00
PUSHNEXT
eword
; Double-Number 6.1.0690
dword DABS,"DABS"
lda PSTKH-1,x
bmi DNEGATE::xt
NEXT
eword
; Core 6.1.0290
dword INCR,"1+"
cpx #$01
bcc stku2
inc PSTKL-1,x
bne :+
inc PSTKH-1,x
: NEXT
stku2: jmp stku_err
eword
stku2 = INCR::stku2
; Core 6.1.0300
dword DECR,"1-"
cpx #$01
bcc stku2
lda PSTKL-1,x
bne :+
dec PSTKH-1,x
: dec PSTKL-1,x
NEXT
eword
.proc m2parm
cpx #$02
bcc stku2
dex
lda PSTKL-1,x
rts
.endproc
; Core 6.1.0120
; would be faster if we could have the stack on the ZP...
dword PLUS,"+"
jsr m2parm
clc
adc PSTKL,x
sta PSTKL-1,x
lda PSTKH-1,x
adc PSTKH,x
sta PSTKH-1,x
NEXT
eword
; Core 6.1.0160
dword MINUS,"-"
jsr m2parm
sec
sbc PSTKL,x
sta PSTKL-1,x
lda PSTKH-1,x
sbc PSTKH,x
sta PSTKH-1,x
NEXT
eword
; Core 6.1.1130
dword PSTORE,"+!"
ENTER
.addr DUP::xt
.addr FETCH::xt
.addr ROT::xt
.addr PLUS::xt
.addr SWAP::xt
.addr STORE::xt
EXIT
eword
; (n1 n2 -- ) n2->YR n1->ZR
.proc _setup2
jsr popay
sta YR+1
sty YR
jsr popay
sta ZR+1
sty ZR
rts
.endproc
; (n1 n2 n3 -- ) n3->YR n2(hw)->ZR n1(lw)->ZACC
.proc _setup3
jsr _setup2
jsr popay
sta ZACC+1
sty ZACC
rts
.endproc
; (n1 n2 -- ) n2->abs->YR n1->abs->ZR
; for division, divisor (remainder) sign stored in dsign
; result sign stored in rsign
.proc _setup2_signed
jsr popay
sta rsign
sta dsign ; divisor sign for symmetric division
bpl :+ ; popay sets sign correctly
jsr _negateay
: sta YR+1
sty YR
jsr popay
sta fsign
pha
eor rsign ; compute result sign
sta rsign
pla
bpl :+
jsr _negateay
: sta ZR+1
sty ZR
rts
rsign: .byte $00 ; result sign
dsign: .byte $00 ; dividend sign
fsign: .byte $00 ; divisor sign
.endproc
.proc _multcommon
jsr _setup2
nosetup: txa
pha
jsr _umult
pla
tax
rts
.endproc
.proc _smultcommon
jsr _setup2_signed
jmp _multcommon::nosetup
.endproc
; Core 6.1.2360
dword UMMULT,"UM*"
jsr _multcommon
push: lda ZACC+1
ldy ZACC
jsr pushay
lda ZACC+3
ldy ZACC+2
PUSHNEXT
eword
; Core 6.1.1810
dword MMULT,"M*"
jsr _smultcommon
bit _setup2_signed::rsign
bpl UMMULT::push ; just push if result not negative
lda ZACC+1
ldy ZACC
jsr _negateay ; negate the low word
php ; and save carry
jsr pushay
plp ; restore carry
lda ZACC+2 ; negate high word
eor #$FF
adc #$00
tay
lda ZACC+3
eor #$FF
adc #$00
PUSHNEXT
eword
; Core 6.1.0090
dword MULT,"*"
ENTER
.addr MMULT::xt
.addr DROP::xt
EXIT
eword
.proc _divcommon
jsr _setup2
signed: lda YR
ora YR+1
bne :+
divzero: ldy #<-10
lda #>-10
jmp _throway
: txa
pha
jsr _udiv
pla
tax
rts
.endproc
.proc _udivmod
jsr _divcommon
push: lda ZACC1+1 ; remainder
ldy ZACC1
jsr pushay
quot: lda ZR+1 ; quotient
ldy ZR
jsr pushay
rts
.endproc
; Core 6.1.2370
dword UMDIVMOD,"UM/MOD"
jsr _setup3
lda YR
ora YR+1
beq _divcommon::divzero
txa
pha
jsr _umdiv
pla
tax
lda ZR+1
ldy ZR
jsr pushay
lda ZACC+1
ldy ZACC
PUSHNEXT
eword
.proc _sdivcommon
jsr _setup2_signed
jmp _divcommon::signed ; go do signed division
.endproc
; non-standard, 16-bit toward-zero signed division
dword SDIVREM,"S/REM"
jsr _sdivcommon
sames: lda ZACC+1 ; get remainder
ldy ZACC
bit _setup2_signed::rsign ; result sign
bpl :+
jsr _negateay
: bit _setup2_signed::dsign ; remainder sign
bpl :+
jsr _negateay
: jsr pushay
lda ZR+1
ldy ZR
bit _setup2_signed::rsign ; quotient sign
bpl :+
jsr _negateay
: PUSHNEXT
eword
; non-standard, 16-bit floored signed division
dword FDIVMOD,"F/MOD"
jsr _sdivcommon
lda _setup2_signed::rsign ; result sign
bpl SDIVREM::sames ; if not negative
lda ZACC+1
ldy ZACC
jsr _invertay
bit _setup2_signed::fsign ; divisor sign = remainder sign
bpl :+ ; already negative
jsr _negateay
: jsr pushay
lda ZR+1
ldy ZR
jsr _invertay
PUSHNEXT
eword
; Core 6.1.0240
; implemented as resolved deferred word so that it may be changed
; from floored to symmetric
dword DIVMOD,"/MOD"
jmp FDIVMOD::xt
eword
; Core 6.1.1890
dword MOD,"MOD"
ENTER
.addr DIVMOD::xt
.addr DROP::xt
EXIT
eword
; Core 6.1.0230
dword DIV,"/"
ENTER
.addr DIVMOD::xt
.addr SWAP::xt
.addr DROP::xt
EXIT
eword
.proc logcom1
jsr popwr
jsr popay
rts
.endproc
; Core 6.1.0720
dword LAND,"AND"
jsr logcom1
and WR+1
pha
tya
and WR
com2: tay
pla
PUSHNEXT
eword
logcom2 = LAND::com2
; Core 6.1.1980
dword LOR,"OR"
jsr logcom1
ora WR+1
pha
tya
ora WR
jmp logcom2
eword
; Core 6.1.2450
dword LXOR,"XOR"
jsr logcom1
eor WR+1
pha
tya
eor WR
jmp logcom2
eword
; Core 6.1.2214
dword SMDIVREM,"SM/REM"
ENTER
.addr TWODUP::xt
.addr LXOR::xt
.addr PtoR::xt
.addr OVER::xt
.addr PtoR::xt
.addr ABS::xt
.addr PtoR::xt
.addr DABS::xt
.addr RtoP::xt
.addr UMDIVMOD::xt
.addr SWAP::xt
.addr RtoP::xt
.addr QNEGATE::xt
.addr SWAP::xt
.addr RtoP::xt
.addr QNEGATE::xt
EXIT
eword
hword SIGNUM,"SIGNUM"
ENTER
.addr DUP::xt
.addr ZEROLT::xt
.addr SWAP::xt
.addr ZEROGT::xt
.addr MINUS::xt
EXIT
eword
; Core 6.1.1561
dword FMDIVMOD,"FM/MOD"
ENTER
.addr DUP::xt
.addr PtoR::xt
.addr SMDIVREM::xt
.addr OVER::xt
.addr SIGNUM::xt
.addr RCOPY::xt
.addr SIGNUM::xt
.addr NEGATE::xt
.addr EQUAL::xt
.addr _IF::xt
.addr _else
.addr DECR::xt
.addr SWAP::xt
.addr RtoP::xt
.addr PLUS::xt
.addr SWAP::xt
EXIT
_else: .addr RDROP::xt
EXIT
eword
; Non standard
; implemented as resolved deferred word so that it may be changed
; from floored to symmetric for derived words
dword MDIVMOD,"M/MOD"
jmp FMDIVMOD::xt
eword
; Core 6.1.0110
dword MULTDIVMOD,"*/MOD"
ENTER
.addr PtoR::xt
.addr MMULT::xt
.addr RtoP::xt
.addr MDIVMOD::xt
EXIT
eword
; Core 6.1.0100
dword MULTDIV,"*/"
ENTER
.addr MULTDIVMOD::xt
.addr NIP::xt
EXIT
eword
; Davex
; read key ( c1 -- c2 )
; c1 = char to place under cursor
; c2 = key that is read
dword XKEY,"XKEY"
jsr popay
tya
stx SPTMP
jsr xrdkey
and #$7F
ldx SPTMP
jsr pusha
NEXT
eword
; Core 6.1.1750
dword KEY,"KEY"
ENTER
NLIT ' '
.addr XKEY::xt
EXIT
eword
; Facility 10.6.1.1755
dword KEYQ,"KEY?"
lda $C000
and #$80
beq :+
lda #$FF
: tay
PUSHNEXT
eword
; Facility 10.6.1.1755
dword PAGE,"PAGE"
lda #AFF
jsr _emit
NEXT
eword
; non-standard
dword HTAB,"HTAB"
jsr popay
sty CH
NEXT
eword
; non-standard
dword VTAB,"VTAB"
jsr popay
tya
jsr TabV ; preserves x
NEXT
eword
; Facility 10.6.1.
dword ATXY,"AT-XY"
ENTER
.addr VTAB::xt
.addr HTAB::xt
EXIT
eword
; Non-standard in 2012, former standard
; note this is NOT a dconst because INBUF
; isn't set until run-time!
hword TIB,"TIB"
lda INBUF+1
ldy INBUF
PUSHNEXT
eword
; non-standard, current input buffer
hvar CIB,"CIB",0
; Core ext 6.2.2218
dword SOURCEID,"SOURCE-ID",0
ENTER
.addr dSOURCEID::xt
.addr FETCH::xt
EXIT
eword
; Core 6.1.0560
dvar PIN,">IN",0
; Non-standard, # of chars in input buffer
hvar NIN,"#IN",0
; Non-standard
; return false if there is no more input
; true if there is
hword INQ,"IN?"
ENTER
.addr PIN::xt
.addr FETCH::xt
.addr NIN::xt
.addr FETCH::xt
.addr UGT::xt
.addr ZEROQ::xt
EXIT
eword
; Core 6.1.2216
; address & content length of source input buffer
dword SOURCE,"SOURCE"
ENTER
.addr CIB::xt
.addr FETCH::xt
.addr NIN::xt
.addr FETCH::xt
EXIT
eword
; Non-standard
; Headerless helper to compute current input buffer char address
hword INPTR,"INPTR"
ENTER
.addr PIN::xt
.addr FETCH::xt
.addr CIB::xt
.addr FETCH::xt
.addr PLUS::xt
EXIT
eword
; Non-standard
; headerless helper to increment the input pointer
hword INC_INPTR,"INPTR+"
ENTER
NLIT 1
.addr PIN::xt
.addr PSTORE::xt
EXIT
eword
; Non-standard
; read current input ( -- c )
hword GETCH,"GETCH"
ENTER
.addr INPTR::xt
.addr CFETCH::xt
.addr INC_INPTR::xt
EXIT
eword
; Davex
; return redirect status
; ( -- f1 f2 ) -- f1 is input redirect status, f2 is output redirect status
dword REDIRECTQ,"REDIRECT?"
stx SPTMP
lda #$00
jsr xredirect
ldx SPTMP
pha
and #%01000000
jsr :+
pla
and #%10000000
jsr :+
NEXT
beq :+
lda #$FF
: tay
jsr pushay
rts
eword
; Non-standard helper to set input source to keyboard or redirect
hword SETKBD,"STKBD"
ENTER
.addr TIB::xt
.addr CIB::xt
.addr STORE::xt
dokbd: NLIT 0
doany: .addr dSOURCEID::xt
.addr STORE::xt
EXIT
eword
; Davex
dconst XMAXLEN,"MAXLEN",(maxlen)
; ( c-addr n1 -- n2 )
; get up to n1 chars from the user's keyboard into the buffer
; at c-addr, returning in n2 the # of characters accepted
; n1 should not be greater than MAXLEN
; since davex returns a counted string, we will convert it in situ
.proc _accept
trace "_accept"
jsr popay ; pop n1
sty XR ; save max length
jsr popwr ; pop c-addr
lda WR ; now use c-addr minus 1
bne :+
dec WR+1
: dec WR
ldy #$00
lda (WR),y ; grab byte where length will go
pha ; and save it
stx SPTMP ; save PSP
lda WR+1
ldy WR
ldx XR
inx ; account for length byte
jsr xgetln2 ; AY=buffer, X=max length
ldx SPTMP ; restore PSP
ldy #$00 ; now get returned length
lda (WR),y
sta XR ; and save it
pla ; restore byte where length went
sta (WR),y
lda XR
jmp pusha
.endproc
; Core 6.1.0695
dword ACCEPT,"ACCEPT"
jsr _accept
NEXT
eword
hword dREFILL,"$REFILL"
lda SOURCE_ID
ora SOURCE_ID+1
beq keyboard
lda SOURCE_ID+1
cmp #SRC_REDIR
beq keyboard ; redirected simulates keyboard input
cmp #SRC_ARG
beq filearg
ldy #<-57
lda #>-57
jmp _throway ; to be implemented later, potentially
filearg: ldy #$00
: stx SPTMP
sty YR
lda SOURCE_ID
jsr xfman_read
; jsr _emit ; uncomment for input echo
ldy YR
ldx SPTMP
bcs filerr
and #$7F
cmp #ACR
beq :+
sta (INBUF),y
iny
bne :- ; go until 256 chars if no CR
lda #$01 ; $0100
bne :++ ; always
: lda #$00 ; $00yy
: jsr pushay
jmp accepted ; accepted, go ahead
filerr: cmp #$4C
bne noteof
cpy #$00
bne accepted ; got some chars before EOF, go interpret
tya
jsr pushay ; FALSE onto stack
jmp SETKBD::xt ; and switch to keyboard input
noteof: jmp _throwp8 ; throw ProDOS error
keyboard: stx SPTMP ; set source ID to reflect keyboard
lda #$00
jsr xredirect ; or redirection depending on status
ldx SPTMP ; of redirection
and #%01000000
beq :+
lda #SRC_REDIR
: sta SOURCE_ID+1
lda INBUF+1
ldy INBUF
jsr pushay
lda #maxlen
jsr pusha
jsr _accept ; accept input
jsr peekay ; get length
tya ; into a
beq accepted ; do nothing on empty buffer
dey ; account for zero-based index
lp: lda (INBUF),y ; mask off all high bits
and #$7F
sta (INBUF),y
dey
cpy #$FF ; can't use minus or zero
bne lp
accepted: ENTER
.addr NIN::xt ; #IN
.addr STORE::xt ; write count
NLIT 0 ; now reset >IN
.addr PIN::xt
.addr STORE::xt ; 0 >IN !
.addr TRUE::xt ; and always return true
EXIT
eword
; Core ext 6.2.2125
dword REFILL,"REFILL"
jmp dREFILL::xt
eword
; make dictionary entry for word at WR, length in XR
; returns with position of new word in AY
.proc _mkdict
ldy XR
beq badword
cpy #$10
bcs badword
lda CHERE+1 ; save HERE for return
pha
lda CHERE
pha
lda DLAST+1 ; get LAST word
ldy DLAST
jsr cworday ; compile link
lda XR
ora #$80 ; default flags+length
jsr cbytea
ldy #$00
: cpy XR
beq done
lda (WR),y
jsr _wconva ; normalize to upper case
sty YR
jsr cbytea ; compile byte (wrecks Y)
ldy YR
iny
bne :-
done: pla ; get old HERE
tay
pla
rts
badword: ldy #<-19 ; definition name too long
lda #>-19
jmp _throway
.endproc
; Convert to upper case
.proc _wconva
and #$7F
cmp #'z'+1 ; upper case conversion
bcs :+ ; not standard...
cmp #'a'
bcc :+
and #$DF
: rts
.endproc
; search dictionary for word at WR, length in XR
; if found, AY != 0 and carry set
; otherwise carry clear and AY=0
.proc _search
trace "_search"
lda DLAST+1 ; TODO: move this out if search order
ldy DLAST ; words are implemented
olp: sta ZR+1
sty ZR
ora ZR
beq notfnd
ldy #$02 ; offset of len+flags
lda (ZR),y
and #F_SMUDG ; see if smudged (invisible)
bne snext
lda (ZR),y ; otherwise next...
and #$0F ; mask in length
cmp XR
bne snext
lda ZR
clc
adc #$03 ; offset to name start
sta chkchr
lda ZR+1
adc #$00
sta chkchr+1
ldy XR
dey ; from 1-based to 0-based
ilp: lda (WR),y
jsr _wconva ; normalize (non-standard)
cmp *,y ; self-modified
chkchr = * - 2
bne snext ; nope
dey
bpl ilp
sec ; loop end, found it!
done: lda ZR+1
ldy ZR
rts
notfnd: clc
bcc done
snext: ldy #$01 ; get pointer to next word
lda (ZR),y ; into AX
pha
dey
lda (ZR),y
tay
pla
jmp olp
.endproc
; non-standard
hword DSEARCH,"$SEARCH"
jsr popxr
jsr popwr
lda XR+1
eor XR
beq none
jsr _search
bcs :+
none: lda #$00
tay
: PUSHNEXT
eword
; with word head in AY
; find code address and put in AY
; set S and V flags to reflect immediate and compile-only flags
; return carry set always
.proc _code
sta ldlen+1
tya
clc
adc #$02
sta ldlen
bcc :+
inc ldlen+1
: lda * ; self-modified
ldlen = * - 2
sta flags
and #$0F ; mask length
sec ; extra one byte to line up
adc ldlen ; add back into low byte
tay
lda ldlen+1
adc #$00
asl flags
bit flags
sec
rts
flags: .byte $00
.endproc
; Non-standard
hword DFLAGS,"$FLAGS"
ENTER
.addr DUP::xt
.addr ZEROQ::xt
.addr _IF::xt
.addr ok
EXIT
ok: NLIT 2
.addr PLUS::xt
EXIT
eword
; Non-standard
hword DXT,"$XT"
jsr popay
cmp #$00
bne :+
cpy #$00
beq done
: jsr _code
done: PUSHNEXT
eword
.proc searcherr
ldy #<-13 ; undefined word
lda #>-13
jmp _throway
.endproc
; Core 6.1.0550
dword rBODY,">BODY"
jsr popwr
clc
jmponly: ldy #$00
lda (WR),y
bcs ckjmp
ldy #$03
cmp #opJSR
beq :+
ckjmp: ldy #$01
cmp #opJMP
beq :+
ldy #<-31 ; not a word for which a body may be found
lda #>-31
jmp _throway
: tya
clc
adc WR
tay
lda WR+1
adc #$00
PUSHNEXT
eword
; headerless get body of JMP only
hword _rJMP,">JMP"
jsr popwr
sec
bcs rBODY::jmponly
eword
.proc _cold
trace "_cold"
lda #<BYE::xt
sta IP
lda #>BYE::xt
sta IP+1
lda #$00
ldx #$17 ; np ZP,y
: sta xczpage,x ; clear system stuff
dex
bpl :-
lda #10
sta ZBASE
lda IHERE+1
sta CHERE+1
lda IHERE
sta CHERE
lda #<ELAST
sta DLAST
lda #>ELAST
sta DLAST+1
lda #<X_DX_LOAD
sta HIMEM
lda #>X_DX_LOAD
sta HIMEM+1
dec HIMEM+1
ldy #$FE
tya
sta (HIMEM),y
iny
sta (HIMEM),y
inc HIMEM+1
lda SOURCE_ID+1
cmp #SRC_ARG
bne :+
jmp FQUIT_xt
; greetings!
: lda #$00
jsr xredirect ; determine if I/O is redirected
and #%11000000 ; mask in bits
bne abort ; and skip greeting if redirected
jsr xmess
.byte "MG's Davex Forth ",$00
lda version
jsr xprint_ver
jsr xmess
.byte $8D,$00
; non-exception abort
abort: ldx #$00 ; init data stack pointer
jmp QUIT_xt
.endproc
_abort = _cold::abort
; see if last word needs forgetting due to exception
; in the middle of defining it
.proc _patch
trace "_patch"
lda DLAST ; see if last word needs forgetting
sta WR
lda DLAST+1
sta WR+1
ldy #$02
lda (WR),y ; get smudge bit
chk = * - 2
and #F_SMUDG ; mask off smudge flag
bne :+ ; fix up if smudged
rts ; otherwise do nothing
: ldy #$01
lda (WR),y
sta DLAST+1
dey
lda (WR),y
sta DLAST
lda OLDHERE::val+1
sta CHERE+1
lda OLDHERE::val
sta CHERE
rts
.endproc
; non-standard helper to return address of WORD buffer, which
; starts at 16 past HERE
hword WORDBUF,"WORDBUF"
ENTER
.addr HERE::xt
NLIT 16
.addr PLUS::xt
EXIT
eword
; Core ext 6.2.2000
; PAD is immediately after WORDBUF
dword PAD,"PAD"
ENTER
.addr WORDBUF::xt
NLIT WORD_SIZE
.addr PLUS::xt
EXIT
eword
; Core 6.1.2070
dword RFETCH,"R@"
stx SPTMP
tsx
pla
sta WR
pla
txs
ldx SPTMP
ldy WR
PUSHNEXT
eword
; Core 6.1.2170
dword StoD,"S>D"
jsr peekay
and #$80
beq :+
lda #$FF
: tay
jsr pushay
NEXT
eword
; non-standard
; ( x1 x2 -- d1 d2 )
dword TWOStoD,"2S>D"
ENTER
.addr PtoR::xt
.addr StoD::xt
.addr RtoP::xt
.addr StoD::xt
EXIT
eword
; Core 6.1.0770
dword BL,"BL"
lda #' '
jsr pusha
NEXT
eword
; Core 6.1.2220
dword SPACE,"SPACE"
lda #' ' ; asm version 1 byte shorter
jsr _emit
NEXT
eword
; Core 6.1.0990
dword CR,"CR"
lda #ACR ; asm version 1 byte shorter
jsr _emit
NEXT
eword
; helper to convert digit to char
.proc _tochar
clc
adc #'0'
cmp #'9'+1
bcc :+
adc #6
cmp #'Z'
bcc :+
adc #6
: rts
.endproc
; routine to convert char to digit
.proc _todigit
pha
lda ZBASE ; cheating, no high byte!
cmp #36
pla
bcs :+
jsr _wconva
sec
: sbc #'0' ; 0-9 conversion
bmi bad
cmp #10 ; if less than 10 we are good
bcc good
sbc #7 ; A-Z conversion
bmi bad
cmp #37
bcc good ; good if less than 37
sbc #7 ; a-z conversion
bmi bad
good: sec
rts
bad: clc
rts
.endproc
; routine to convert a number at WR len XR
; start by initializing current number to 0
; then for each digit left-to-right, multiply the number
; by the current radix in BASE and adding the digit
; return carry set if conversion was successful
; and number in AY
.proc _parsenum
trace "_parsenum"
clc
ror mflag
ldy #$00 ; clear y and use it to