mirror of
https://github.com/mgcaret/davex-mg-utils.git
synced 2025-02-09 02:31:34 +00:00
5313 lines
122 KiB
ArmAsm
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
|