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
|
||
|
sty YR ; init 2nd multiplicand
|
||
|
sty YR+1 ; which also accumulates total
|
||
|
pnum2: stx SPTMP ; data SP gonna get trashed
|
||
|
lda ZBASE
|
||
|
sta ZR ; ZR undisturbed by multiply
|
||
|
lda ZBASE+1 ; so first multiplicand will be base
|
||
|
sta ZR+1
|
||
|
;ldy #$00
|
||
|
sty nflag
|
||
|
lp: sty XR+1 ; save Y
|
||
|
jsr _umult ; since _umult kills it
|
||
|
lda ZACC ; copy results to 2nd multiplicand
|
||
|
sta YR
|
||
|
lda ZACC+1
|
||
|
sta YR+1
|
||
|
ldy XR+1 ; get Y back
|
||
|
lda (WR),y ; now grab a char to convert
|
||
|
and #$7F ; strip high bit
|
||
|
cmp #'-'
|
||
|
beq minus
|
||
|
jsr _todigit ; convert to digit
|
||
|
bcc bad
|
||
|
cmp ZBASE ; make sure smaller than base
|
||
|
bcs bad ; (cheating by not checking high byte)
|
||
|
clc ; now add to accumulating value
|
||
|
adc YR
|
||
|
sta YR
|
||
|
bcc :+
|
||
|
inc YR+1
|
||
|
: iny ; count # of digits processed
|
||
|
sty XR+1 ; and save count for interested parties
|
||
|
cpy XR ; and see if we are done
|
||
|
bcc lp ; (if not, keep going)
|
||
|
done: lda YR+1 ; and return the #
|
||
|
ldy YR
|
||
|
ldx SPTMP
|
||
|
bit nflag
|
||
|
bpl :+
|
||
|
jsr _negateay
|
||
|
: sec
|
||
|
rts
|
||
|
bad: bit mflag
|
||
|
bmi done
|
||
|
ldx SPTMP
|
||
|
clc
|
||
|
rts
|
||
|
minus: bit mflag
|
||
|
bmi bad
|
||
|
cpy #$00
|
||
|
bne bad
|
||
|
ror nflag ; carry is set
|
||
|
iny
|
||
|
bne lp
|
||
|
nflag: .byte $00
|
||
|
mflag: .byte $00
|
||
|
.endproc
|
||
|
|
||
|
; Core 6.1.0570
|
||
|
dword GNUMBER,">NUMBER"
|
||
|
jsr popxr
|
||
|
jsr popwr
|
||
|
jsr popay
|
||
|
sta ZR+1
|
||
|
sty ZR
|
||
|
ldy #$00
|
||
|
sec
|
||
|
ror _parsenum::mflag
|
||
|
jsr _parsenum::pnum2
|
||
|
jsr pushay
|
||
|
lda WR
|
||
|
clc
|
||
|
adc XR+1
|
||
|
tay
|
||
|
lda WR+1
|
||
|
adc #$00
|
||
|
jsr pushay
|
||
|
lda XR
|
||
|
sec
|
||
|
sbc XR+1
|
||
|
jsr pusha
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; backing variable for pictured numeric output
|
||
|
hvar dPPTR,"$PPTR",0
|
||
|
|
||
|
; Core 6.1.0490
|
||
|
dword PBEGIN,"<#"
|
||
|
ENTER
|
||
|
.addr WORDBUF::xt
|
||
|
NLIT WORD_SIZE
|
||
|
.addr PLUS::xt
|
||
|
.addr dPPTR::xt
|
||
|
.addr STORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1670
|
||
|
; ( c -- ), put c into pictured numeric output buffer
|
||
|
dword PHOLD,"HOLD"
|
||
|
ENTER
|
||
|
.addr dPPTR::xt ; Current pictured output pointer var
|
||
|
.addr FETCH::xt ; get the saved address
|
||
|
.addr DECR::xt ; move to next lower address
|
||
|
.addr DUP::xt ; make a second copy
|
||
|
.addr dPPTR::xt
|
||
|
.addr STORE::xt ; write back to pointer var
|
||
|
.addr CSTORE::xt ; write character to location
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2210
|
||
|
dword PSIGN,"SIGN"
|
||
|
jsr popay
|
||
|
and #$80
|
||
|
beq :+
|
||
|
lda #'-'
|
||
|
jsr pusha
|
||
|
jmp PHOLD::xt
|
||
|
: NEXT
|
||
|
eword
|
||
|
|
||
|
; non-standard, unsigned divide 32-bit by 16-bit
|
||
|
; leaving 32-bit quotient and 16-bit remainder
|
||
|
; ( ud u -- u-rem ud-quot )
|
||
|
; borrowed from sixtyforth
|
||
|
dword UMLDIVMOD,"UML/MOD"
|
||
|
ENTER
|
||
|
.addr PtoR::xt
|
||
|
.addr RCOPY::xt
|
||
|
NLIT 0
|
||
|
.addr SWAP::xt
|
||
|
.addr UMDIVMOD::xt
|
||
|
.addr RtoP::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr PtoR::xt
|
||
|
.addr UMDIVMOD::xt
|
||
|
.addr RtoP::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0030
|
||
|
dword PNUM,"#"
|
||
|
ENTER
|
||
|
.addr BASE::xt
|
||
|
.addr FETCH::xt
|
||
|
.addr UMLDIVMOD::xt ; divide by BASE
|
||
|
.addr ROT::xt ; put remainder in front
|
||
|
CODE
|
||
|
jsr popay ; get remainder
|
||
|
tya ; only low byte is practical
|
||
|
jsr _tochar ; convert to ASCII
|
||
|
jsr pusha ; and back onto stack
|
||
|
jmp PHOLD::xt ; then put in output buffer
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0050
|
||
|
dword PNUMS,"#S"
|
||
|
ENTER
|
||
|
another: .addr PNUM::xt
|
||
|
.addr TWODUP::xt
|
||
|
.addr LOR::xt
|
||
|
.addr _IFFALSE::xt ; is zero?
|
||
|
.addr another ; nope, do another digit
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0040
|
||
|
; ( xd -- c-addr u )
|
||
|
dword PDONE,"#>"
|
||
|
ENTER
|
||
|
.addr TWODROP::xt ; drop remaining quotient
|
||
|
getstr: .addr dPPTR::xt ; c-addr
|
||
|
.addr FETCH::xt
|
||
|
.addr WORDBUF::xt ; now compute u
|
||
|
NLIT WORD_SIZE
|
||
|
.addr PLUS::xt
|
||
|
.addr dPPTR::xt
|
||
|
.addr FETCH::xt
|
||
|
.addr MINUS::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; general number formatter for standard number output words
|
||
|
; it's slow, but it does it all and saves space with the words that follow
|
||
|
; ( d u1 f -- c-addr u2 ) u1 = field size f = true if signed output desired
|
||
|
hword DFMT,"DFMT"
|
||
|
ENTER
|
||
|
.addr SWAP::xt
|
||
|
.addr PtoR::xt
|
||
|
.addr PBEGIN::xt
|
||
|
.addr _IF::xt ; check f
|
||
|
.addr us1 ; unsigned if f is false
|
||
|
.addr DUP::xt ; duplicate cell with sign
|
||
|
.addr NROT::xt ; and put it behind d
|
||
|
.addr DABS::xt
|
||
|
.addr _SKIP2::xt ; skip next 2 words
|
||
|
us1: NLIT 0 ; no sign printed
|
||
|
.addr NROT::xt
|
||
|
.addr PNUMS::xt ; perform conversion
|
||
|
.addr ROT::xt ; get sign back to front
|
||
|
.addr PSIGN::xt ; add sign if needed
|
||
|
.addr PDONE::xt
|
||
|
.addr RtoP::xt ; get field size back
|
||
|
.addr MINUS::xt ; if less than 0, have to add blanks
|
||
|
lp: .addr DUP::xt
|
||
|
.addr ZEROLT::xt ; is less than 0?
|
||
|
.addr _IF::xt
|
||
|
.addr fielddn ; nope, done
|
||
|
.addr INCR::xt ; increment
|
||
|
.addr BL::xt
|
||
|
.addr PHOLD::xt ; hold a blank
|
||
|
.addr _JUMP::xt ; and go back to lp
|
||
|
.addr lp
|
||
|
fielddn: .addr TWODROP::xt ; drop c-addr and leftovers
|
||
|
.addr _JUMP::xt
|
||
|
.addr PDONE::getstr ; and return c-addr u for result
|
||
|
eword
|
||
|
|
||
|
; Double-number 8.6.1070
|
||
|
dword DDOTR,"D.R"
|
||
|
ENTER
|
||
|
dosdotr: NLIT 1 ; signed
|
||
|
dodotr: .addr DFMT::xt
|
||
|
.addr TYPE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Double-number 8.6.1060
|
||
|
dword DDOT,"D."
|
||
|
ENTER
|
||
|
NLIT 0 ; field size
|
||
|
.addr DDOTR::xt
|
||
|
.addr SPACE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2330
|
||
|
dword UDOTR,"U.R"
|
||
|
ENTER
|
||
|
.addr PtoR::xt
|
||
|
NLIT 0 ; unsigned S>D
|
||
|
.addr RtoP::xt
|
||
|
NLIT 0 ; want unsigned
|
||
|
.addr _JUMP::xt
|
||
|
.addr DDOTR::dodotr
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0210
|
||
|
dword DOTR,".R"
|
||
|
ENTER
|
||
|
.addr PtoR::xt
|
||
|
.addr StoD::xt
|
||
|
.addr RtoP::xt
|
||
|
.addr _JUMP::xt
|
||
|
.addr DDOTR::dosdotr
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2320
|
||
|
dword UDOT,"U."
|
||
|
.if 0
|
||
|
; faster
|
||
|
ENTER
|
||
|
NLIT 0 ; unsigned S>D
|
||
|
.addr PBEGIN::xt
|
||
|
.addr PNUMS::xt
|
||
|
.addr PDONE::xt
|
||
|
.addr TYPE::xt
|
||
|
.addr SPACE::xt
|
||
|
EXIT
|
||
|
.else
|
||
|
; smaller
|
||
|
ENTER
|
||
|
NLIT 0
|
||
|
.addr UDOTR::xt
|
||
|
.addr SPACE::xt
|
||
|
EXIT
|
||
|
.endif
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0180
|
||
|
dword DOT,"."
|
||
|
.if 0
|
||
|
; faster
|
||
|
ENTER
|
||
|
.addr StoD::xt
|
||
|
.addr _IF::xt
|
||
|
.addr pos
|
||
|
NLIT '-'
|
||
|
.addr EMIT::xt
|
||
|
.addr ABS::xt
|
||
|
pos: .addr UDOT::xt
|
||
|
EXIT
|
||
|
.else
|
||
|
; smaller
|
||
|
ENTER
|
||
|
NLIT 0
|
||
|
.addr DOTR::xt
|
||
|
.addr SPACE::xt
|
||
|
EXIT
|
||
|
.endif
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1900
|
||
|
dword MOVE,"MOVE"
|
||
|
jsr _swap
|
||
|
jsr popay
|
||
|
sta YR+1
|
||
|
sty YR
|
||
|
ldy #<func
|
||
|
lda #>func
|
||
|
jsr string_op_ay
|
||
|
NEXT
|
||
|
func: sta (YR),y
|
||
|
inc YR
|
||
|
bne :+
|
||
|
inc YR+1
|
||
|
: rts
|
||
|
eword
|
||
|
|
||
|
; non-standard
|
||
|
; ( c-addr1 u c-addr2 -- ) place string at (c-addr1,u) in counted form
|
||
|
; at c-addr 2
|
||
|
dword PLACE,"PLACE"
|
||
|
ENTER
|
||
|
.addr TWODUP::xt
|
||
|
.addr STORE::xt
|
||
|
.addr INCR::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr MOVE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword PRP8ERR,".P8_ERR"
|
||
|
jsr popay
|
||
|
tya
|
||
|
stx SPTMP
|
||
|
jsr xProDOS_er
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
.proc _message
|
||
|
jsr peekay
|
||
|
cmp #P8_ER_RNG
|
||
|
beq PRP8ERR::xt
|
||
|
stx SPTMP
|
||
|
jsr xmess
|
||
|
.byte "Msg #",$00
|
||
|
ldx SPTMP
|
||
|
ENTER
|
||
|
.addr DOT::xt
|
||
|
EXIT
|
||
|
.endproc
|
||
|
|
||
|
; Non-standard
|
||
|
; This appears as a deferrable
|
||
|
; to be overridden by something more helpful later
|
||
|
dword MESSAGE,"MESSAGE"
|
||
|
jmp _message
|
||
|
eword
|
||
|
|
||
|
; Exception 9.6.1.0875
|
||
|
; push exception stack frame onto stack and execute token
|
||
|
dword CATCH,"CATCH"
|
||
|
jsr popwr ; remove xt from stack
|
||
|
inc flag ; flag catch active
|
||
|
lda IP+1 ; save IP on stack
|
||
|
pha
|
||
|
lda IP
|
||
|
pha
|
||
|
lda rstk ; save old catch return stack if any
|
||
|
pha
|
||
|
txa ; save data stack pointer
|
||
|
pha
|
||
|
stx SPTMP
|
||
|
tsx ; save return stack pointer
|
||
|
stx rstk
|
||
|
ldx SPTMP
|
||
|
lda WR+1 ; put xt back on stack
|
||
|
ldy WR
|
||
|
jsr pushay
|
||
|
ENTER
|
||
|
.addr EXECUTE::xt
|
||
|
CODE
|
||
|
; if we got here, no exception
|
||
|
lda #$00
|
||
|
sta WR
|
||
|
sta WR+1
|
||
|
pla ; drop old data stack ptr
|
||
|
fixup: pla
|
||
|
sta rstk
|
||
|
pla
|
||
|
sta IP ; restore previous IP
|
||
|
pla
|
||
|
sta IP+1
|
||
|
dec flag
|
||
|
lda WR+1
|
||
|
ldy WR
|
||
|
PUSHNEXT
|
||
|
flag: .byte $00
|
||
|
rstk: .byte $00
|
||
|
eword
|
||
|
|
||
|
; Exception 9.6.1.2275
|
||
|
dword THROW,"THROW"
|
||
|
jsr peekay
|
||
|
ora #$00
|
||
|
bne :+
|
||
|
tya
|
||
|
bne :+
|
||
|
dex ; peek told us there was at least one item
|
||
|
NEXT
|
||
|
: jsr popwr
|
||
|
ithrow:
|
||
|
.if TRACE
|
||
|
txa
|
||
|
pha
|
||
|
lda WR
|
||
|
sta TRADR
|
||
|
lda WR+1
|
||
|
sta TRADR+1
|
||
|
jsr xmess
|
||
|
.byte "[THROW,",$00
|
||
|
jsr _dtrace
|
||
|
lda #']'
|
||
|
jsr _emit
|
||
|
pla
|
||
|
tax
|
||
|
.endif
|
||
|
lda CATCH::flag ; see if active CATCH
|
||
|
beq uncaught
|
||
|
ldx CATCH::rstk ; restore prior return stack ptr
|
||
|
txs
|
||
|
pla ; restore prior data stack ptr
|
||
|
tax
|
||
|
jmp CATCH::fixup ; now "return" from catch
|
||
|
uncaught: lda #$FF
|
||
|
cmp WR+1
|
||
|
bne :+
|
||
|
lda WR
|
||
|
cmp #<-1
|
||
|
beq abort
|
||
|
cmp #<-2
|
||
|
beq abort
|
||
|
: stx SPTMP
|
||
|
jsr xmess
|
||
|
.byte " Uncaught: ",$00
|
||
|
ldx SPTMP
|
||
|
cpx #PSTK_SZ-10 ; check space left in parameter stack
|
||
|
bcc :+ ; and reserve enough to handle the
|
||
|
ldx #PSTK_SZ-10 ; error if needed
|
||
|
: lda WR+1
|
||
|
ldy WR
|
||
|
jsr pushay
|
||
|
ENTER
|
||
|
.addr MESSAGE::xt
|
||
|
CODE
|
||
|
jmp QUIT_xt
|
||
|
abort: jmp _abort
|
||
|
eword
|
||
|
|
||
|
; Throw an exceptiopn because of a ProDOS 8 error.
|
||
|
.proc _throwp8
|
||
|
tay
|
||
|
lda #P8_ER_RNG
|
||
|
; fall through to _throway
|
||
|
.endproc
|
||
|
|
||
|
; this word bypasses the stack ops and executes throw
|
||
|
; the contents of AX should *not* be zero
|
||
|
.proc _throway
|
||
|
sta WR+1
|
||
|
sty WR
|
||
|
jmp THROW::ithrow
|
||
|
.endproc
|
||
|
|
||
|
; non-standard parse helper
|
||
|
hword ISSPC,"ISSPACE?"
|
||
|
ENTER
|
||
|
.addr BL::xt
|
||
|
.addr INCR::xt
|
||
|
.addr ULT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; non-standard parse helper
|
||
|
hword ISNOTSPC,"ISNOTSPACE?"
|
||
|
ENTER
|
||
|
.addr ISSPC::xt
|
||
|
.addr ZEROQ::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2020
|
||
|
; ( "name" -- c-addr u )
|
||
|
dword PARSE_NAME,"PARSE-NAME"
|
||
|
ENTER
|
||
|
l1: .addr INQ::xt ; is there input?
|
||
|
.addr _IF::xt ;
|
||
|
.addr none ; if not, just return empty-handed
|
||
|
.addr GETCH::xt ; get char ( -- c )
|
||
|
.addr ISSPC::xt ; is it a space? ( -- tf )
|
||
|
.addr _IFFALSE::xt ; or, rather if not ( tf -- )
|
||
|
.addr l1 ; do loop if it is
|
||
|
.addr INPTR::xt ; ( -- c-addr )
|
||
|
.addr DECR::xt ; fixup because INPTR is 1 ahead now
|
||
|
NLIT 0 ; and we have 1 char ( -- c-addr u=1 )
|
||
|
l2: .addr INQ::xt ; is there input?
|
||
|
.addr _IF::xt
|
||
|
.addr e1 ; if not, exit
|
||
|
.addr INCR::xt ; ( c-addr u -- c-addr u=u+1 ) count non-spaces
|
||
|
.addr GETCH::xt ; ( c-addr u -- c-addr u c )
|
||
|
.addr ISSPC::xt ; ( c-addr u c -- c-addr u n )
|
||
|
.addr _IF::xt ; ( c-addr u n -- c-addr u tf )
|
||
|
.addr l2 ; not a space, keep parsing
|
||
|
e1: EXIT
|
||
|
none: .addr INPTR::xt
|
||
|
NLIT 0
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2020
|
||
|
dword PARSE,"PARSE"
|
||
|
ENTER
|
||
|
.addr PtoR::xt ; save delimeter
|
||
|
.addr INPTR::xt ; get current input address
|
||
|
NLIT 0 ; and start with a count of 0
|
||
|
l1: .addr INQ::xt ; is there input available?
|
||
|
.addr _IF::xt
|
||
|
.addr e1 ; false branch exits
|
||
|
.addr GETCH::xt ; get the next char
|
||
|
.addr RCOPY::xt ; and copy the delimiter from return stack
|
||
|
.addr EQUAL::xt ; is it the same char?
|
||
|
.addr _IF::xt
|
||
|
.addr i1 ; false branch increments count and continues loop
|
||
|
e1: .addr RDROP::xt
|
||
|
EXIT
|
||
|
i1: .addr INCR::xt
|
||
|
.addr _JUMP::xt
|
||
|
.addr l1
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2450
|
||
|
; ( char "<chars>ccc<char>" -- c-addr )
|
||
|
dword WORD,"WORD"
|
||
|
ENTER
|
||
|
.addr PARSE::xt ; ( char -- c-addr u ) parse the word
|
||
|
.addr DUP::xt ; dup count
|
||
|
NLIT WORD_SIZE ; max size of word space
|
||
|
.addr ULT::xt ; unsigned <
|
||
|
.addr _IF::xt ; was it less than?
|
||
|
.addr bad ; nope, error
|
||
|
.addr DUP::xt ; dup length again
|
||
|
.addr WORDBUF::xt ; address of word buf
|
||
|
.addr CSTORE::xt ; store length
|
||
|
.addr WORDBUF::xt ; wordbuf again
|
||
|
.addr INCR::xt ; +1
|
||
|
.addr SWAP::xt ; make sure stack is ( c-addr u )
|
||
|
.addr MOVE::xt ; move the data
|
||
|
.addr WORDBUF::xt ; and put word buffer address on stack
|
||
|
EXIT
|
||
|
bad: NLIT -18 ; "parsed string overflow"
|
||
|
.ADDR THROW::xt ; never returns
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0895
|
||
|
dword CHAR,"CHAR"
|
||
|
ENTER
|
||
|
.addr PARSE_NAME::xt
|
||
|
.addr DROP::xt
|
||
|
.addr CFETCH::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; helper for words that must parse and find
|
||
|
; a dictionary entry
|
||
|
hword PARSEFIND,"$WORD"
|
||
|
ENTER
|
||
|
.addr PARSE_NAME::xt
|
||
|
.addr DSEARCH::xt
|
||
|
.addr DUP::xt
|
||
|
.addr _IF::xt
|
||
|
.addr exc
|
||
|
EXIT
|
||
|
exc: .addr DROP::xt
|
||
|
NLIT -13
|
||
|
.addr THROW::xt
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2520
|
||
|
dword CCHAR,"[CHAR]",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.addr CHAR::xt
|
||
|
.addr COMMA::xt ; compile fast literal
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; helper
|
||
|
.proc _parsenametowrxr
|
||
|
ENTER
|
||
|
.addr PARSE_NAME::xt
|
||
|
CODE
|
||
|
jsr popxr
|
||
|
jmp popwr
|
||
|
.endproc
|
||
|
|
||
|
; Core 6.1.0070
|
||
|
dword FIND,"'"
|
||
|
ENTER
|
||
|
.addr PARSEFIND::xt
|
||
|
.addr DXT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2510
|
||
|
dword CFIND,"[']",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.addr FIND::xt ; find xt
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr LIT::xt ; compile LIT
|
||
|
.addr COMMA::xt ; compile xt as literal
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Headerless helper to make a new dictionary entry
|
||
|
hword MKENTRY,"MKENTRY"
|
||
|
ENTER
|
||
|
.addr PARSE_NAME::xt
|
||
|
.addr HERE::xt ; if successfully parsed, set OLDHERE
|
||
|
.addr OLDHERE::xt
|
||
|
.addr STORE::xt
|
||
|
CODE
|
||
|
jsr popxr
|
||
|
jsr popwr
|
||
|
jsr _mkdict
|
||
|
sta DLAST+1
|
||
|
sty DLAST
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1000
|
||
|
dword CREATE,"CREATE"
|
||
|
ENTER
|
||
|
.addr MKENTRY::xt
|
||
|
NLIT opJSR
|
||
|
.addr CCOMMA::xt
|
||
|
.addr LIT::xt
|
||
|
.addr pushda
|
||
|
.addr COMMA::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.1173
|
||
|
dword DEFER,"DEFER"
|
||
|
ENTER
|
||
|
.addr MKENTRY::xt
|
||
|
NLIT opJMP
|
||
|
.addr CCOMMA::xt
|
||
|
.addr LIT::xt
|
||
|
.addr _undefined
|
||
|
.addr COMMA::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.1177
|
||
|
dword DEFERAT,"DEFER@"
|
||
|
ENTER
|
||
|
.addr _rJMP::xt
|
||
|
.addr FETCH::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2500
|
||
|
dword STATEI,"[",F_CONLY|F_IMMED
|
||
|
lda #$00
|
||
|
sta ZSTATE
|
||
|
sta ZSTATE+1
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2540
|
||
|
dword STATEC,"]"
|
||
|
ldy #$01
|
||
|
sty ZSTATE
|
||
|
dey
|
||
|
sty ZSTATE+1
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.1.1175
|
||
|
dword DEFERSTO,"DEFER!"
|
||
|
ENTER
|
||
|
.addr _rJMP::xt
|
||
|
.addr STORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0450
|
||
|
dword COLON,":"
|
||
|
ENTER
|
||
|
.addr MKENTRY::xt
|
||
|
NLIT opJSR
|
||
|
.addr CCOMMA::xt
|
||
|
.addr LIT::xt
|
||
|
.addr enter
|
||
|
.addr COMMA::xt
|
||
|
.addr LAST::xt
|
||
|
NLIT 2
|
||
|
.addr PLUS::xt
|
||
|
.addr DUP::xt
|
||
|
.addr CFETCH::xt
|
||
|
NLIT F_SMUDG ; smudge it
|
||
|
.addr LOR::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr CSTORE::xt
|
||
|
.addr STATEC::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0455
|
||
|
; compile an anonymous definition
|
||
|
dword NONAME,":NONAME"
|
||
|
ENTER
|
||
|
.addr HERE::xt
|
||
|
NLIT opJSR
|
||
|
.addr CCOMMA::xt
|
||
|
.word LIT::xt
|
||
|
.addr enter
|
||
|
.addr COMMA::xt
|
||
|
.addr STATEC::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0460
|
||
|
dword SEMI,";",F_IMMED|F_CONLY
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr exit_next
|
||
|
dosemi: .addr LAST::xt
|
||
|
NLIT 2
|
||
|
.addr PLUS::xt
|
||
|
.addr DUP::xt
|
||
|
.addr CFETCH::xt
|
||
|
NLIT F_SMUDG ; unsmudge it
|
||
|
.addr INVERT::xt
|
||
|
.addr LAND::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr CSTORE::xt
|
||
|
.addr STATEI::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Headerless helper word for DOES> and ;CODE
|
||
|
hword SEMIS,"SEMIS"
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr exit_code
|
||
|
.addr _JUMP
|
||
|
.addr SEMI::dosemi
|
||
|
eword
|
||
|
|
||
|
; Core part of DOES> implementation
|
||
|
; modify the most recent CREATEed definition to jsr
|
||
|
; to the address immediately following whoever
|
||
|
; JSRed to this.
|
||
|
.proc SDOES
|
||
|
pla
|
||
|
clc
|
||
|
adc #$01
|
||
|
sta ZR
|
||
|
pla
|
||
|
adc #$00
|
||
|
sta ZR+1
|
||
|
ldy DLAST
|
||
|
lda DLAST+1
|
||
|
jsr _code
|
||
|
sta WR+1
|
||
|
sty WR
|
||
|
ldy #$00
|
||
|
lda (WR),y
|
||
|
cmp #$20
|
||
|
bne csmm
|
||
|
iny
|
||
|
lda ZR
|
||
|
sta (WR),y
|
||
|
iny
|
||
|
lda ZR+1
|
||
|
sta (WR),y
|
||
|
NEXT
|
||
|
csmm: ldy #<-22 ; control structure mismatch
|
||
|
lda #>-22
|
||
|
jmp _throway
|
||
|
.endproc
|
||
|
controlmm = SDOES::csmm
|
||
|
|
||
|
; Core 6.1.1250
|
||
|
; DOES> is... complicated
|
||
|
; when a colon def compiles DOES>, the DOES> closes the definition
|
||
|
; with semis and compiles the following to the word:
|
||
|
; jsr SDOES ( see above )
|
||
|
; jsr ENTER
|
||
|
; RPLUCK INCR
|
||
|
; and then goes back into compile mode until ;
|
||
|
; this has the effect that when the word containing DOES> is executed
|
||
|
; it replaces the effect of the most recently-defined word (provided it was
|
||
|
; created by CREATE) with new effects, namely the word will push
|
||
|
; it's data address onto the stack and execute the code following DOES>
|
||
|
; e.g. : MKARRAY CREATE CELLS ALLOT DOES> SWAP CELLS + ;
|
||
|
; 2 MKARRAY FOO -> OK
|
||
|
; 0 FOO U. -> 35120 OK
|
||
|
; 1 FOO U. -> 35122 OK
|
||
|
dword DOES,"DOES>",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.addr SEMIS::xt ; close current definition for code
|
||
|
.addr COMP_CLIT::xt
|
||
|
.byte opJSR ; C: jsr
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr SDOES ; C: (jsr) SDOES
|
||
|
.addr COMP_CLIT::xt
|
||
|
.byte opJSR ; C: jsr
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr enter ; C: (jsr) ENTER
|
||
|
.word COMP_LIT::xt
|
||
|
.addr RPLUCK::xt ; C: RPLUCK
|
||
|
.word COMP_LIT::xt
|
||
|
.addr INCR::xt ; C: INCR
|
||
|
NLIT 2
|
||
|
.addr STATE::xt
|
||
|
.addr STORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1200
|
||
|
dword DEPTH,"DEPTH"
|
||
|
txa
|
||
|
tay
|
||
|
lda #$00
|
||
|
PUSHNEXT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2030
|
||
|
dword PICK,"PICK"
|
||
|
jsr popay
|
||
|
sty XR
|
||
|
txa
|
||
|
sec
|
||
|
sbc XR
|
||
|
bcc :+
|
||
|
stx SPTMP
|
||
|
tax
|
||
|
jsr popay
|
||
|
ldx SPTMP
|
||
|
PUSHNEXT
|
||
|
: jmp stku_err
|
||
|
eword
|
||
|
|
||
|
; Tools 15.6.1.0220
|
||
|
; I thought about DEPTH 1- 0 DO I PICK . -1 +LOOP
|
||
|
; but it doesn't save anything
|
||
|
dword DOTS,".S"
|
||
|
.if 1
|
||
|
; secondary version, uses pictured numeric output
|
||
|
; 17 bytes shorter than native
|
||
|
ENTER
|
||
|
NLIT '{'
|
||
|
.addr EMIT::xt
|
||
|
.addr SPACE::xt
|
||
|
.addr DEPTH::xt
|
||
|
.addr DUP::xt
|
||
|
.addr DOT::xt
|
||
|
NLIT ':'
|
||
|
.addr EMIT::xt
|
||
|
.addr SPACE::xt
|
||
|
.addr DUP::xt
|
||
|
.addr _IF::xt
|
||
|
.addr done ; early out for empty stack
|
||
|
lp: .addr DECR::xt
|
||
|
.addr DUP::xt
|
||
|
.addr PtoR::xt
|
||
|
.addr PICK::xt
|
||
|
.addr DOT::xt
|
||
|
.addr RtoP::xt
|
||
|
.addr DUP::xt
|
||
|
.addr _IFFALSE::xt
|
||
|
.addr lp
|
||
|
done: .addr DROP::xt
|
||
|
NLIT '}'
|
||
|
.addr EMIT::xt
|
||
|
EXIT
|
||
|
.else
|
||
|
; native version, uses DaveX functions
|
||
|
stx SPTMP
|
||
|
jsr xmess
|
||
|
.byte "{ ",$00
|
||
|
lda #$00
|
||
|
ldy SPTMP
|
||
|
jsr xprdec_2
|
||
|
jsr xmess
|
||
|
.byte " : ",$00
|
||
|
ldx #$00
|
||
|
lp: cpx SPTMP
|
||
|
bcc :+
|
||
|
lda #'}'
|
||
|
jsr _emit
|
||
|
NEXT
|
||
|
: ldy PSTKL,x
|
||
|
lda PSTKH,x
|
||
|
bpl :+
|
||
|
pha
|
||
|
lda #'-'
|
||
|
jsr _emit
|
||
|
pla
|
||
|
jsr _negateay
|
||
|
: stx XR
|
||
|
jsr xprdec_2
|
||
|
ldx XR
|
||
|
lda #' '
|
||
|
jsr _emit
|
||
|
inx
|
||
|
jmp lp
|
||
|
.endif
|
||
|
eword
|
||
|
DOTS_xt = DOTS::xt
|
||
|
|
||
|
; Non-standard, but useful
|
||
|
dword ZEROSP,"0SP"
|
||
|
ldx #$00
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Exception ext 9.6.2.0670
|
||
|
dword ABORT,"ABORT"
|
||
|
ENTER
|
||
|
;.addr ZEROSP::xt
|
||
|
NLIT -1
|
||
|
.addr THROW::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Non-standard
|
||
|
dword ABORTBANG,"ABORT!",F_IMMED
|
||
|
jmp ABORT::xt
|
||
|
eword
|
||
|
|
||
|
; headerless word implementing text interpreter
|
||
|
hword INTERPRET,"INTERPRET"
|
||
|
loop: ENTER
|
||
|
.addr INQ::xt ; is there input?
|
||
|
.addr _IF::xt ; ( tf -- )
|
||
|
.addr done ; done if none
|
||
|
.addr PARSE_NAME::xt ; otherwise parse next word
|
||
|
CODE
|
||
|
jsr popxr
|
||
|
jsr popwr
|
||
|
lda XR+1
|
||
|
eor XR
|
||
|
beq loop ; if length is 0, loop back
|
||
|
jsr _search
|
||
|
bcc trynum
|
||
|
jsr _code ; get code address & flags
|
||
|
php ; save flags
|
||
|
jsr pushay
|
||
|
plp
|
||
|
bvs conly ; compile-only
|
||
|
bmi execute ; immediate
|
||
|
lda ZSTATE
|
||
|
ora ZSTATE+1
|
||
|
beq execute
|
||
|
compile: ldy #<COMMA::xt
|
||
|
lda #>COMMA::xt
|
||
|
jsr pushay
|
||
|
execute: ENTER
|
||
|
.addr EXECUTE::xt
|
||
|
CODE
|
||
|
lp2: jmp loop
|
||
|
done: EXIT
|
||
|
trynum: jsr _parsenum
|
||
|
bcc badword
|
||
|
jsr pushay
|
||
|
lda ZSTATE
|
||
|
ora ZSTATE+1
|
||
|
beq lp2
|
||
|
jsr peekay
|
||
|
ora #$00
|
||
|
beq compile ; fast literal
|
||
|
ldy #<LIT::xt ; otherwise compile literal
|
||
|
lda #>LIT::xt
|
||
|
jsr cworday
|
||
|
jmp compile
|
||
|
badword: ldy #$00
|
||
|
pr: cpy XR
|
||
|
bcs notfnd
|
||
|
lda (WR),y
|
||
|
jsr _emit
|
||
|
iny
|
||
|
bne pr
|
||
|
notfnd: lda #'?'
|
||
|
jsr _emit
|
||
|
ldy #<-13
|
||
|
lda #>-13
|
||
|
barf: jmp _throway
|
||
|
conly: php
|
||
|
lda ZSTATE
|
||
|
ora ZSTATE+1
|
||
|
bne :+
|
||
|
plp
|
||
|
dex ; drop xt from stack
|
||
|
ldy #<-14
|
||
|
lda #>-14
|
||
|
bne barf
|
||
|
: plp
|
||
|
bmi execute
|
||
|
bpl compile
|
||
|
eword
|
||
|
_undefined = INTERPRET::notfnd
|
||
|
|
||
|
; Core ext 6.2.2182
|
||
|
; TODO: if/when file words are implemented, this has to deal with them
|
||
|
; as well, and some words that use it (EVALUATE) will need to be modified
|
||
|
dword SAVEINPUT,"SAVE-INPUT"
|
||
|
ENTER
|
||
|
.addr SOURCE::xt ; put CIB and #IN on stack
|
||
|
.addr PIN::xt
|
||
|
.addr FETCH::xt ; put >IN on stack
|
||
|
NLIT 3
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2148
|
||
|
dword RESTOREINPUT,"RESTORE-INPUT"
|
||
|
ENTER
|
||
|
.addr DROP::xt
|
||
|
.addr PIN::xt
|
||
|
.addr STORE::xt
|
||
|
.addr NIN::xt
|
||
|
.addr STORE::xt
|
||
|
.addr CIB::xt
|
||
|
.addr STORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1360
|
||
|
; Save the current input source to the return stack
|
||
|
; set input up for string to evaluate, then put it all back
|
||
|
dword EVALUATE,"EVALUATE"
|
||
|
ENTER
|
||
|
.addr SOURCEID::xt ; puts one item on stack
|
||
|
.addr SAVEINPUT::xt ; puts n+1 items on stack, with n at the top
|
||
|
.addr INCR::xt ; and add one for source ID
|
||
|
.addr NPtoR::xt ; save on return stack
|
||
|
.addr PtoR::xt ; and save the count on return stack
|
||
|
NLIT -1
|
||
|
.addr dSOURCEID::xt
|
||
|
.addr STORE::xt ; set source ID to -1
|
||
|
NLIT 0
|
||
|
.addr PIN::xt ; set >IN to 0
|
||
|
.addr STORE::xt
|
||
|
.addr NIN::xt
|
||
|
.addr STORE::xt ; string length to #IN
|
||
|
.addr CIB::xt
|
||
|
.addr STORE::xt ; string addr to CIB
|
||
|
.addr INTERPRET::xt ; interpret from there until nothing left
|
||
|
.addr RtoP::xt ; get count back
|
||
|
.addr NRtoP::xt ; and pull them off the return stack
|
||
|
.addr DECR::xt ; account for what we added
|
||
|
.addr RESTOREINPUT::xt ; restore input spec
|
||
|
.addr dSOURCEID::xt
|
||
|
.addr STORE::xt ; and input source ID
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
.proc _status
|
||
|
lda SOURCE_ID
|
||
|
ora SOURCE_ID+1
|
||
|
bne :+
|
||
|
lda #ACR
|
||
|
jsr _emit
|
||
|
: NEXT
|
||
|
.endproc
|
||
|
|
||
|
dword STATUS,"STATUS"
|
||
|
jmp _status
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2050
|
||
|
; Empty the return stack, store zero in SOURCE-ID if it is present, make the
|
||
|
; user input device the input source, and enter interpretation state. Do not
|
||
|
; display a message. Repeat the following:
|
||
|
; * Accept a line from the input source into the input buffer, set >IN to zero,
|
||
|
; and interpret.
|
||
|
; * Display the implementation-defined system prompt if in interpretation
|
||
|
; state, all processing has been completed, and no ambiguous condition exists.
|
||
|
dword QUIT,"QUIT"
|
||
|
lda #$00 ; enter interpreting state
|
||
|
sta ZSTATE
|
||
|
sta ZSTATE+1
|
||
|
stx SPTMP
|
||
|
ldx RSSAV ; clear return stack
|
||
|
txs
|
||
|
ldx SPTMP
|
||
|
jsr _patch ; forget most recent def if smudged
|
||
|
ENTER ; outer interpreter
|
||
|
source0: .addr SETKBD::xt ; set keyboard source
|
||
|
lp: .addr STATUS::xt ; display status (default: CR if source ID=0)
|
||
|
.addr REFILL::xt ; get input (TODO, before this SOURCE-ID should reflect redirection)
|
||
|
.addr _IF::xt ; did we get any?
|
||
|
.addr source0 ; if not, set source to keyboard, go again
|
||
|
.addr INTERPRET::xt ; otherwise, interpret what we got
|
||
|
.addr SOURCEID::xt ; what source?
|
||
|
.addr _IFFALSE::xt ; something other than keyboard?
|
||
|
.addr lp ; yes, don't print any prompts
|
||
|
.addr REDIRECTQ::xt ; I/O redirected?
|
||
|
.addr DROP::xt ; nobody cares about poor output redirection :(
|
||
|
.addr _IFFALSE::xt ; not redirecting?
|
||
|
.addr lp ; we are! don't do prompt
|
||
|
.addr SPACE::xt ; otherwise, a space
|
||
|
.addr _SMART::xt ; compiling?
|
||
|
.addr interp ; no, do normal prompt
|
||
|
SLIT "[OK]" ; otherwise do compiling prompt
|
||
|
.addr TYPE::xt
|
||
|
.addr _JUMP::xt
|
||
|
.addr lp
|
||
|
interp: SLIT "OK"
|
||
|
.addr TYPE::xt
|
||
|
.addr _JUMP::xt
|
||
|
.addr lp
|
||
|
eword
|
||
|
QUIT_xt = QUIT::xt
|
||
|
|
||
|
; headerless word to do first QUIT when there is a file on the command line
|
||
|
hword FQUIT,"FQUIT"
|
||
|
lda SOURCE_ID ; already have file refnum?
|
||
|
beq :+ ; if not go ahead and set it up
|
||
|
jmp _cold::abort ; otherwise abort
|
||
|
: lda #$00 ; enter interpreting state
|
||
|
sta ZSTATE
|
||
|
sta ZSTATE+1
|
||
|
ldx RSSAV ; clear return stack
|
||
|
txs
|
||
|
jsr xgetparm_n
|
||
|
jsr xfman_open
|
||
|
bcc :+
|
||
|
jmp xProDOS_err ; totally bomb if file not available
|
||
|
: sta SOURCE_ID
|
||
|
ldx #$00 ; clear parameter stack
|
||
|
ENTER
|
||
|
.addr TIB::xt
|
||
|
.addr CIB::xt
|
||
|
.addr STORE::xt
|
||
|
.addr _JUMP::xt
|
||
|
.addr QUIT::lp
|
||
|
eword
|
||
|
FQUIT_xt = FQUIT::xt
|
||
|
|
||
|
; Core 6.1.0080
|
||
|
dword RPAREN,"(",F_IMMED
|
||
|
ENTER
|
||
|
NLIT ')'
|
||
|
.addr PARSE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Tools 15.6.1.0600
|
||
|
dword VIEW,"?"
|
||
|
ENTER
|
||
|
.addr FETCH::xt
|
||
|
.addr DOT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0200
|
||
|
dword DOTPAREN,".(",F_IMMED
|
||
|
ENTER
|
||
|
NLIT ')'
|
||
|
.addr PARSE::xt
|
||
|
.addr TYPE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dconst CBUFF,"CATBUFF",catbuff
|
||
|
; Davex
|
||
|
dconst FBUFF,"FBUFF",filebuff
|
||
|
; Davex
|
||
|
dconst FBUFF2,"FBUFF2",filebuff2
|
||
|
; Davex
|
||
|
dconst FBUFF3,"FBUFF3",filebuff3
|
||
|
|
||
|
; Davex
|
||
|
dword DOTFTYPE,".FTYPE"
|
||
|
jsr popay
|
||
|
tya
|
||
|
stx SPTMP
|
||
|
jsr xprint_ftype
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword DOTACCESS,".ACCESS"
|
||
|
jsr popay
|
||
|
tya
|
||
|
stx SPTMP
|
||
|
jsr xprint_access
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
|
||
|
; Davex
|
||
|
dword U3PERCENT,"3U%"
|
||
|
jsr popaxy
|
||
|
sta num+2
|
||
|
stx num+1
|
||
|
sty num
|
||
|
ldx SPTMP
|
||
|
jsr popaxy
|
||
|
jsr xpercent
|
||
|
ldx SPTMP
|
||
|
jsr pusha
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
dword UPERCENT,"U%"
|
||
|
ENTER
|
||
|
.addr TWOStoD::xt
|
||
|
.addr U3PERCENT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword DOTSD,".SD"
|
||
|
jsr popay
|
||
|
tya
|
||
|
stx SPTMP
|
||
|
jsr xprint_sd
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword CSTYPE,"CSTYPE"
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
jsr xprint_path
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword BUILD_LOCAL,"BUILD_LOCAL"
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
jsr xbuild_local
|
||
|
ldx SPTMP
|
||
|
PUSHNEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword PREDIRECT,"+REDIRECT"
|
||
|
stx SPTMP
|
||
|
lda #$FF
|
||
|
redir: jsr xredirect
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword MREDIRECT,"-REDIRECT"
|
||
|
stx SPTMP
|
||
|
lda #$00
|
||
|
beq PREDIRECT::redir
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword YESNO,"Y/N"
|
||
|
stx SPTMP
|
||
|
jsr xyesno
|
||
|
yn2: beq :+
|
||
|
lda #$FF
|
||
|
: tay
|
||
|
ldx SPTMP
|
||
|
PUSHNEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword YESNO2,"Y/N2"
|
||
|
jsr popay
|
||
|
tya
|
||
|
stx SPTMP
|
||
|
jsr xyesno2
|
||
|
jmp YESNO::yn2
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword BELL,"BELL"
|
||
|
stx SPTMP
|
||
|
jsr xbell
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword PRDATE,".DATE"
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
jsr xpr_date_ay
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword PRTIME,".TIME"
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
jsr xpr_time_ay
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
.proc dircommon
|
||
|
stx SPTMP
|
||
|
jsr xpush_level
|
||
|
ldx SPTMP
|
||
|
rts
|
||
|
.endproc
|
||
|
|
||
|
; Davex
|
||
|
dword TDIR,"<DIR"
|
||
|
jsr dircommon
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
jsr xdir_setup
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword TTDIR,"<<DIR"
|
||
|
jsr dircommon
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
jsr xdir_setup2
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword DIRP,"DIR+"
|
||
|
stx SPTMP
|
||
|
jsr xread1dir
|
||
|
ldx SPTMP
|
||
|
bcs :+
|
||
|
ldy #<catbuff
|
||
|
lda #>catbuff
|
||
|
done: PUSHNEXT
|
||
|
: lda #$00
|
||
|
tay
|
||
|
beq done
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword DIRT,"DIR>"
|
||
|
stx SPTMP
|
||
|
jsr xdir_finish
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword CHKWAIT,"WAIT?"
|
||
|
stx SPTMP
|
||
|
jsr xcheck_wait
|
||
|
ldx SPTMP
|
||
|
lda #$00
|
||
|
bcc :+
|
||
|
lda #$ff
|
||
|
: tay
|
||
|
PUSHNEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword IOPOLL,"IOPOLL"
|
||
|
jsr xpoll_io ; all regs preserved
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword DIRTY,"DIRTY"
|
||
|
stx SPTMP
|
||
|
jsr xdirty
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
dword PRVER,".VER"
|
||
|
jsr popay
|
||
|
tya
|
||
|
stx SPTMP
|
||
|
jsr xprint_ver
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Davex
|
||
|
; ( c -- ay x true ) or ( c -- false )
|
||
|
dword XINFO,"XINFO"
|
||
|
jsr popay
|
||
|
stx SPTMP
|
||
|
tya
|
||
|
tax
|
||
|
jsr xshell_info
|
||
|
stx XR
|
||
|
ldx SPTMP
|
||
|
bcs bad
|
||
|
sta YR+1
|
||
|
sty YR
|
||
|
jsr pushay
|
||
|
lda XR
|
||
|
jsr pusha
|
||
|
lda #$FF
|
||
|
bne :+
|
||
|
bad: lda #$00
|
||
|
: tay
|
||
|
PUSHNEXT
|
||
|
eword
|
||
|
|
||
|
.proc xpmgr_do
|
||
|
stx SPTMP
|
||
|
jsr xpmgr
|
||
|
command: .byte $00
|
||
|
parm1: .word $0000
|
||
|
parm2: .word $0000
|
||
|
ldx SPTMP
|
||
|
NEXT
|
||
|
.endproc
|
||
|
|
||
|
.proc xpmgr_begin
|
||
|
sta xpmgr_do::command
|
||
|
lda #opNOP
|
||
|
sta xpmgr_do::parm2+1 ; for one-parm commands, the common case
|
||
|
sta xpmgr_do::parm2
|
||
|
jsr _swap
|
||
|
jsr popay
|
||
|
sta xpmgr_do::parm1+1
|
||
|
sty xpmgr_do::parm1
|
||
|
rts
|
||
|
.endproc
|
||
|
|
||
|
; Davex - append one counted string to another
|
||
|
dword CAPPENDS,"CS+CS"
|
||
|
lda #pm_appay
|
||
|
jsr xpmgr_begin
|
||
|
jsr popay
|
||
|
jmp xpmgr_do
|
||
|
eword
|
||
|
|
||
|
; Davex - append one character to counted string
|
||
|
dword CAPPEND,"CS+"
|
||
|
lda #pm_appch
|
||
|
jsr xpmgr_begin
|
||
|
jsr popay
|
||
|
tya
|
||
|
jmp xpmgr_do
|
||
|
eword
|
||
|
|
||
|
; Davex - remove path segment
|
||
|
dword CDROP,"CS/-"
|
||
|
lda #pm_up
|
||
|
jsr xpmgr_begin
|
||
|
jmp xpmgr_do
|
||
|
eword
|
||
|
|
||
|
; Davex - add / if none in string
|
||
|
dword CSLASH,"CS+/"
|
||
|
lda #pm_slashif
|
||
|
jsr xpmgr_begin
|
||
|
jmp xpmgr_do
|
||
|
eword
|
||
|
|
||
|
; Davex - copy counted string from PARM1 to PARM2
|
||
|
dword CSMOVE,"CSMOVE"
|
||
|
lda #pm_copy
|
||
|
jsr xpmgr_begin
|
||
|
jsr popay
|
||
|
sta xpmgr_do::parm2+1
|
||
|
sta xpmgr_do::parm2
|
||
|
jmp xpmgr_do
|
||
|
eword
|
||
|
|
||
|
; ProDOS
|
||
|
dword P8MLI,"MLI"
|
||
|
jsr popay
|
||
|
sta parmlist+1
|
||
|
sty parmlist
|
||
|
jsr popay
|
||
|
sty callnum
|
||
|
stx SPTMP
|
||
|
jsr mli
|
||
|
callnum: .byte $00
|
||
|
parmlist: .addr $0000
|
||
|
chkerr1: ldx SPTMP ; other words enter here to restore SP first
|
||
|
chkerr: bcc :+ ; check for error, throw it if present
|
||
|
jmp _throwp8
|
||
|
: NEXT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0710
|
||
|
dword ALLOT,"ALLOT"
|
||
|
jsr popay
|
||
|
pha
|
||
|
tya
|
||
|
clc
|
||
|
adc CHERE
|
||
|
sta CHERE
|
||
|
pla
|
||
|
adc CHERE+1
|
||
|
sta CHERE+1
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0825
|
||
|
dword BUFFER,"BUFFER:"
|
||
|
ENTER
|
||
|
.addr CREATE::xt
|
||
|
.addr ALLOT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0880
|
||
|
dword CELLP,"CELL+"
|
||
|
ENTER
|
||
|
NLIT 2
|
||
|
.addr PLUS::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0890
|
||
|
dword CELLS,"CELLS"
|
||
|
ENTER
|
||
|
NLIT 2
|
||
|
.addr MULT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0897
|
||
|
dword CHARP,"CHAR+"
|
||
|
jmp INCR::xt
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0945
|
||
|
; in our case, the semantics of COMPILE, and ,
|
||
|
; are the same
|
||
|
dword COMPILEC,"COMPILE,"
|
||
|
jmp COMMA::xt
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0950
|
||
|
dword CONSTANT,"CONSTANT"
|
||
|
ENTER
|
||
|
.addr MKENTRY::xt
|
||
|
.addr COMP_CLIT
|
||
|
.byte opJSR
|
||
|
.addr COMP_LIT
|
||
|
.addr pushconst
|
||
|
.addr COMMA::xt ; compile value
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2405
|
||
|
dword VALUE,"VALUE"
|
||
|
jmp CONSTANT::xt
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2295
|
||
|
dword TO,"TO",F_IMMED
|
||
|
ENTER ; interpretation
|
||
|
.addr PARSEFIND::xt
|
||
|
.addr DXT::xt
|
||
|
.addr rBODY::xt
|
||
|
.addr _SMART::xt
|
||
|
.addr interp
|
||
|
.addr COMP_LIT::xt ; compilation semantics
|
||
|
.addr LIT::xt ; compile literal
|
||
|
.addr COMMA::xt ; compile address of VALUE / LOCAL
|
||
|
.addr COMP_LIT::xt ; we get to do a neat trick here
|
||
|
interp: .addr STORE::xt ; and re-use the interpretation store
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0980
|
||
|
dword COUNT,"COUNT"
|
||
|
ENTER
|
||
|
.addr DUP::xt
|
||
|
.addr INCR::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr CFETCH::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1550
|
||
|
dword WFIND,"FIND"
|
||
|
ENTER
|
||
|
.addr DUP::xt ; ( c-addr -- c-addr c-addr )
|
||
|
.addr COUNT::xt ; ( c-addr -- c-addr c-addr u )
|
||
|
.addr DSEARCH::xt ; ( c-addr -- c-addr 0|xt )
|
||
|
.addr DUP::xt ; ( c-addr 0|xt -- c-addr 0|xt 0|xt )
|
||
|
.addr _IF::xt ; ( c-addr 0|xt 0|xt -- c-addr 0|xt )
|
||
|
.addr notfound ; if ( c-addr 0 -- )
|
||
|
.addr NIP::xt ; otherwise it's ( c-addr xt -- ), drop c-addr
|
||
|
CODE ; do some native work
|
||
|
jsr popay
|
||
|
jsr _code
|
||
|
php
|
||
|
jsr pushay
|
||
|
lda #$00 ; -1 = immediate flag
|
||
|
ldy #$01
|
||
|
plp
|
||
|
bmi :+ ; yep, immediate
|
||
|
jsr _negateay ; otherwise change to -1
|
||
|
: jsr pushay ; and push it
|
||
|
NEXT
|
||
|
notfound: EXIT
|
||
|
eword
|
||
|
|
||
|
; headerless helper to compile a string
|
||
|
hword CSTRING,"CSTRING"
|
||
|
ldy #<cbytea
|
||
|
lda #>cbytea
|
||
|
jsr string_op_ay
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; swap the current interpretation string buffer
|
||
|
; and return it
|
||
|
hword NEXTSBUF,"NEXTSBUF"
|
||
|
ENTER
|
||
|
.addr CSBUF::xt
|
||
|
.addr FETCH::xt
|
||
|
.addr SBUF1::xt
|
||
|
.addr EQUAL::xt
|
||
|
.addr _IF::xt
|
||
|
.addr gobuf1
|
||
|
.addr SBUF2::xt
|
||
|
.addr _SKIP::xt ; skip next instruction
|
||
|
gobuf1: .addr SBUF1::xt
|
||
|
.addr DUP::xt
|
||
|
.addr CSBUF::xt
|
||
|
.addr STORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
hword CSCOMM,"CSCOMM"
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr _JUMP::xt ; C: _JUMP
|
||
|
.addr HERE::xt ; ( -- a ) resolve address
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr controlmm ; C: <f>(unresolved)
|
||
|
.addr HERE::xt ; ( a -- a b )
|
||
|
.addr SWAP::xt ; ( a -- b a ) so we can resolve a first
|
||
|
NLIT '"' ; parse delimiter
|
||
|
.addr PARSE::xt ; ( b a -- b a c-addr u )
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0855
|
||
|
; need to compile the following sequence:
|
||
|
; _JUMP <f> <string> f:PUSH <c-addr> PUSH <u>
|
||
|
dwordq SQ,"S'",F_IMMED
|
||
|
ENTER
|
||
|
.addr _SMART::xt ; smart word
|
||
|
.addr interp
|
||
|
.addr CSCOMM::xt ; ( ... -- b a c-addr u )
|
||
|
.addr SWAP::xt ; ( b a c-addr u -- b a u c-addr )
|
||
|
.addr OVER::xt ; ( ... -- b a u c-addr u )
|
||
|
.addr CSTRING::xt ; ( ... -- b a u ) compile string into program
|
||
|
.addr SWAP::xt ; ( ... -- b u a )
|
||
|
.addr HERE::xt ; ( ... -- b u a h )
|
||
|
.addr SWAP::xt ; ( ... -- b u h a )
|
||
|
.addr STORE::xt ; ( ... -- b u ) resolve <f>
|
||
|
.addr SWAP::xt ; ( ... -- u b ) compile addr first
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr LIT::xt ; C: LIT
|
||
|
.addr COMMA::xt ; ( ... -- u ) compile b as c-addr
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr LIT::xt ; C: LIT
|
||
|
.addr COMMA::xt ; ( ... -- u ) compile u
|
||
|
EXIT
|
||
|
interp: .addr NEXTSBUF::xt ; go to next string buffer
|
||
|
.addr DUP::xt ; make extra copy
|
||
|
NLIT '"'
|
||
|
.addr PARSE::xt ; ( ... -- c-addr1 caddr1 c-addr2 u )
|
||
|
.addr PtoR::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr RCOPY::xt
|
||
|
.addr MOVE::xt
|
||
|
.addr RtoP::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.0855
|
||
|
dwordq CQ,"C'",F_IMMED
|
||
|
ENTER
|
||
|
.addr _SMART::xt
|
||
|
.addr interp
|
||
|
.addr CSCOMM::xt ; ( ... -- b a c-addr u )
|
||
|
.addr DUP::xt ; ( ... -- b a c-addr u u )
|
||
|
.addr CCOMMA::xt ; ( ... -- b a c-addr u ) compile copy of u
|
||
|
.addr CSTRING::xt ; ( ... -- b a ) compile string into program
|
||
|
.addr HERE::xt ; ( ... -- b a h )
|
||
|
.addr SWAP::xt ; ( ... -- b h a )
|
||
|
.addr STORE::xt ; ( ... -- b ) resolve jump
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr LIT::xt ; C: LIT
|
||
|
.addr COMMA::xt ; ( ... -- b ) compile b as c-addr
|
||
|
EXIT
|
||
|
interp: NLIT '"'
|
||
|
.addr PARSE::xt
|
||
|
.addr NEXTSBUF::xt
|
||
|
.addr PLACE::xt
|
||
|
.addr CSBUF::xt
|
||
|
.addr FETCH::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0190
|
||
|
; interpretation semantics defined like .(
|
||
|
dwordq DOTQ,".'",F_IMMED
|
||
|
ENTER
|
||
|
.addr _SMART::xt
|
||
|
.addr interp
|
||
|
.addr SQ::xt ; get msg addr on stack
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr TYPE::xt ; display it
|
||
|
EXIT
|
||
|
interp: NLIT '"'
|
||
|
.addr PARSE::xt
|
||
|
.addr TYPE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; word compiled by ABORT",
|
||
|
hword _ABORTQ,"_ABORT'"
|
||
|
ENTER
|
||
|
.addr ROT::xt ; move param after string
|
||
|
.addr _IF::xt
|
||
|
.addr noabort
|
||
|
NLIT CATCH::flag
|
||
|
.addr CFETCH::xt
|
||
|
.addr _IF::xt
|
||
|
.addr dotype ; if catch flag set, do not type
|
||
|
.addr TWODROP::xt
|
||
|
.addr _SKIP::xt
|
||
|
dotype: .addr TYPE::xt
|
||
|
.addr ZEROSP::xt
|
||
|
NLIT -2
|
||
|
.addr THROW::xt
|
||
|
noabort: .addr TWODROP::xt ; drop string
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
|
||
|
; Exception ext 9.6.2.0680
|
||
|
dwordq ABORTQ,"ABORT'",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.addr SQ::xt ; compile string
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr _ABORTQ::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1540
|
||
|
; ( c-addr u char -- ) - fill u chars (bytes) at c-addr with char
|
||
|
dword FILL,"FILL"
|
||
|
jsr popay
|
||
|
fchary: sty char
|
||
|
ldy #<func
|
||
|
lda #>func
|
||
|
jsr string_op_ay
|
||
|
NEXT
|
||
|
func: lda #$FF ; self-modified
|
||
|
char = * - 1
|
||
|
sta (XR),y
|
||
|
rts
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.1350
|
||
|
dword ERASE,"ERASE"
|
||
|
ldy #$00
|
||
|
jmp FILL::fchary
|
||
|
eword
|
||
|
|
||
|
; String 17.6.1.0780
|
||
|
dword BLANK,"BLANK"
|
||
|
ldy #' '
|
||
|
jmp FILL::fchary
|
||
|
eword
|
||
|
|
||
|
|
||
|
; Core 6.1.1710
|
||
|
; TODO: de-dup shared code with COLON
|
||
|
; and future COMPILE-ONLY
|
||
|
dword IMMEDIATE,"IMMEDIATE"
|
||
|
ENTER
|
||
|
.addr LAST::xt
|
||
|
NLIT 2
|
||
|
.addr PLUS::xt
|
||
|
.addr DUP::xt
|
||
|
.addr CFETCH::xt
|
||
|
NLIT F_IMMED
|
||
|
.addr LOR::xt
|
||
|
.addr SWAP::xt
|
||
|
.addr CSTORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1780
|
||
|
dword LITERAL,"LITERAL",F_CONLY|F_IMMED
|
||
|
jsr peekay
|
||
|
cmp #$00
|
||
|
beq fastlit
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr LIT::xt
|
||
|
.addr COMMA::xt
|
||
|
EXIT
|
||
|
fastlit: jmp COMMA::xt
|
||
|
eword
|
||
|
|
||
|
; helper function to perform a function in ZR
|
||
|
; XR times
|
||
|
.proc _iter
|
||
|
lp: lda XR
|
||
|
ora XR+1
|
||
|
bne :+
|
||
|
rts
|
||
|
lda XR
|
||
|
bne :+
|
||
|
dec XR+1
|
||
|
: dec XR
|
||
|
jsr doit
|
||
|
jmp lp
|
||
|
doit: jmp (ZR)
|
||
|
.endproc
|
||
|
|
||
|
.proc _shiftcom1
|
||
|
sta ZR+1
|
||
|
sty ZR
|
||
|
jsr popxr
|
||
|
jsr popwr
|
||
|
jmp _iter
|
||
|
.endproc
|
||
|
|
||
|
.proc _shiftcom2
|
||
|
lda WR+1
|
||
|
ldy WR
|
||
|
PUSHNEXT
|
||
|
.endproc
|
||
|
|
||
|
; Core 6.1.1805
|
||
|
dword LSHIFT,"LSHIFT"
|
||
|
ldy #<goleft
|
||
|
lda #>goleft
|
||
|
jsr _shiftcom1
|
||
|
jmp _shiftcom2
|
||
|
goleft: asl WR
|
||
|
rol WR+1
|
||
|
rts
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2230
|
||
|
dword SPACES,"SPACES"
|
||
|
ldy #<doit
|
||
|
lda #>doit
|
||
|
sta ZR+1
|
||
|
sty ZR
|
||
|
jsr popxr
|
||
|
jsr _iter
|
||
|
NEXT
|
||
|
doit: lda #' '
|
||
|
jmp _emit
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0330
|
||
|
dword TWOMULT,"2*"
|
||
|
jsr popwr
|
||
|
jsr LSHIFT::goleft
|
||
|
jmp _shiftcom2
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2162
|
||
|
dword RSHIFT,"RSHIFT"
|
||
|
ldy #<goright
|
||
|
lda #>goright
|
||
|
jsr _shiftcom1
|
||
|
jmp _shiftcom2
|
||
|
goright: lsr WR+1
|
||
|
ror WR
|
||
|
rts
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0330
|
||
|
dword TWODIV,"2/"
|
||
|
jsr popwr
|
||
|
jsr RSHIFT::goright
|
||
|
jmp _shiftcom2
|
||
|
eword
|
||
|
|
||
|
.proc _marker
|
||
|
ENTER
|
||
|
.addr HERE::xt
|
||
|
.addr LAST::xt
|
||
|
.addr CREATE::xt
|
||
|
.addr COMMA::xt ; compile LAST first
|
||
|
.addr COMMA::xt ; then HERE
|
||
|
CODE
|
||
|
jsr SDOES
|
||
|
ENTER
|
||
|
.addr RPLUCK::xt
|
||
|
.addr INCR::xt
|
||
|
CODE
|
||
|
jsr popwr
|
||
|
ldy #$00
|
||
|
lda (WR),y
|
||
|
sta DLAST
|
||
|
iny
|
||
|
lda (WR),y
|
||
|
sta DLAST+1
|
||
|
iny
|
||
|
lda (WR),y
|
||
|
sta CHERE
|
||
|
iny
|
||
|
lda (WR),y
|
||
|
sta CHERE+1
|
||
|
NEXT
|
||
|
.endproc
|
||
|
|
||
|
; Core 6.2.1850
|
||
|
dword MARKER,"MARKER"
|
||
|
jmp _marker
|
||
|
eword
|
||
|
|
||
|
; Tools 15.6.1.2465
|
||
|
dword WORDS,"WORDS"
|
||
|
sta SPTMP
|
||
|
lda DLAST
|
||
|
sta WR
|
||
|
lda DLAST+1
|
||
|
sta WR+1
|
||
|
lp: lda WR
|
||
|
ora WR+1
|
||
|
bne :+
|
||
|
done: lda SPTMP
|
||
|
NEXT
|
||
|
: lda WR+1
|
||
|
jsr PrByte
|
||
|
lda WR
|
||
|
jsr PrByte
|
||
|
lda #' '
|
||
|
jsr _emit
|
||
|
ldy #$02
|
||
|
lda (WR),y
|
||
|
and #$0F
|
||
|
beq nxt
|
||
|
clc
|
||
|
tax
|
||
|
pr: iny
|
||
|
lda (WR),y
|
||
|
jsr _emit
|
||
|
dex
|
||
|
bne pr
|
||
|
nxt: lda #ACR
|
||
|
jsr _emit
|
||
|
jsr xcheck_wait
|
||
|
bcs done
|
||
|
ldy #$00
|
||
|
lda (WR),y
|
||
|
pha
|
||
|
iny
|
||
|
lda (WR),y
|
||
|
sta WR+1
|
||
|
pla
|
||
|
sta WR
|
||
|
jmp lp
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2033
|
||
|
dword POSTPONE,"POSTPONE",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.addr PARSEFIND::xt
|
||
|
.addr DXT::xt
|
||
|
.addr COMMA::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2410
|
||
|
dword VARIABLE,"VARIABLE"
|
||
|
ENTER
|
||
|
.addr CREATE::xt
|
||
|
NLIT 2
|
||
|
.addr ALLOT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2395
|
||
|
dword UNUSED,"UNUSED"
|
||
|
ENTER
|
||
|
.addr DHIMEM::xt
|
||
|
.addr FETCH::xt
|
||
|
.addr HERE::xt
|
||
|
.addr MINUS::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2120
|
||
|
dword RECURSE,"RECURSE",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.word LAST::xt
|
||
|
.word DXT::xt
|
||
|
.word COMMA::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1880
|
||
|
dword MIN,"MIN"
|
||
|
ENTER
|
||
|
.word TWODUP::xt
|
||
|
.word SGT::xt
|
||
|
com: .word _IF::xt
|
||
|
.word noswap
|
||
|
.word SWAP::xt
|
||
|
noswap: .word DROP::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1870
|
||
|
dword MAX,"MAX"
|
||
|
ENTER
|
||
|
.word TWODUP::xt
|
||
|
.word SLT::xt
|
||
|
.word _JUMP::xt
|
||
|
.word MIN::com
|
||
|
eword
|
||
|
|
||
|
; Core ext 6.2.2440
|
||
|
; ( test low high ) true if test is within low (inclusive) and high (exclusive)
|
||
|
; required for loop checks
|
||
|
dword WITHIN,"WITHIN"
|
||
|
ENTER
|
||
|
.addr OVER::xt
|
||
|
.addr MINUS::xt
|
||
|
.addr PtoR::xt
|
||
|
.addr MINUS::xt
|
||
|
.addr RtoP::xt
|
||
|
.addr ULT::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Headerless helper to put the top two stack entries in numeric order
|
||
|
dword ORDER,"ORDER"
|
||
|
ENTER
|
||
|
.addr TWODUP::xt
|
||
|
.addr MAX::xt
|
||
|
.addr PtoR::xt
|
||
|
.addr MIN::xt
|
||
|
.addr RtoP::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; and now the do ... loop stuff, here's the architecture:
|
||
|
; a loop is compiled as such
|
||
|
; |_DO _JUMP leave-addr|(1)word word word word|_LOOP|-PLOOP _JUMP (1)| UNLOOP
|
||
|
; where the first group is applied by DO, dropping _JUMP address on the
|
||
|
; stack. Any instance of LEAVE will jump here. leave-addr is resolved when LOOP
|
||
|
; /+LOOP are compiled, which put 1 _PLOOP/_PLOOP, followed by _UNLOOP, with the effect that
|
||
|
; leave jumps to the _JUMP following _DO and
|
||
|
; when executing:
|
||
|
; _DO puts the loop control parameters on the Rstack, and finishes with a jmp
|
||
|
; to _SKIP2 to skip the flow control structure.
|
||
|
; any LEAVE will jump back to the _JUMP, which will jump forward to the UNLOOP
|
||
|
; and finally, _LOOP/_PLOOP will increment/offset the index and compare it to
|
||
|
; the ending value using WITHIN and will either fall through the to the UNLOOP
|
||
|
; or jump back to the beginning of the loop
|
||
|
|
||
|
; run-time semantics for DO, must be primitive or account for ENTER on rstack
|
||
|
; ( -- limit index )(R: -- leave_address index limit )
|
||
|
hword _DO,"_DO"
|
||
|
lda IP+1 ; put leave target
|
||
|
pha ; onto the stack
|
||
|
lda IP
|
||
|
pha
|
||
|
jsr popay ; get index
|
||
|
pha
|
||
|
tya
|
||
|
pha
|
||
|
jsr popay ; get limit
|
||
|
pha
|
||
|
tya
|
||
|
pha
|
||
|
jmp _SKIP2::xt ; skip LEAVE's target
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1240
|
||
|
dword DO,"DO",F_IMMED|F_CONLY
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr _DO::xt ; compile execution semantics
|
||
|
.addr HERE::xt ; ( C: -- do-sys ) address for LEAVE
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr _JUMP::xt ; LEAVE will jump here
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr controlmm ; LOOP/+LOOP will jump to do-sys+4, after this word
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.2380
|
||
|
; Really, it's 3RDROP
|
||
|
dword UNLOOP,"UNLOOP",F_CONLY
|
||
|
pla
|
||
|
pla
|
||
|
pla
|
||
|
pla
|
||
|
pla
|
||
|
pla
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; run-time semantics for +LOOP
|
||
|
; with increment on stack and (R: index limit )
|
||
|
; leaves new loop parms on return stack
|
||
|
; if the new index is in the termination range,
|
||
|
; exits via _SKIP, otherwise exits via _JUMP
|
||
|
; WR: increment
|
||
|
; XR: computed next index
|
||
|
; YR: limit
|
||
|
; ZR: computed limit bounds
|
||
|
hword _PLOOP,"_+LOOP"
|
||
|
jsr popwr ; increment to WR
|
||
|
pla ; get limit from return stack
|
||
|
sta YR ; put limit in YR
|
||
|
clc
|
||
|
adc WR ; add increment to get upper bound low byte
|
||
|
sta ZR ; to put in ZR
|
||
|
pla ; get the high byte
|
||
|
sta YR+1 ; limit in YR
|
||
|
adc WR+1 ; add high byte of increment
|
||
|
sta ZR+1 ; and put in ZR
|
||
|
pla ; now get current index low byte
|
||
|
clc
|
||
|
adc WR ; add increment
|
||
|
sta XR ; new index low byte to XR
|
||
|
pla ; high byte
|
||
|
adc WR+1 ; high byte of increment
|
||
|
sta XR+1 ; into XR
|
||
|
pha ; and new index back on return stack
|
||
|
lda XR ; high byte then low byte
|
||
|
pha
|
||
|
tay ; low byte to Y
|
||
|
lda XR+1 ; high byte to A
|
||
|
jsr pushay ; and put new index on forth stack
|
||
|
lda YR+1 ; finally put limit back on return stack
|
||
|
pha ; high byte
|
||
|
lda YR ; then low byte
|
||
|
pha
|
||
|
tay ; low byte to Y
|
||
|
lda YR+1 ; get high byte
|
||
|
jsr pushay ; and limit on forth stack
|
||
|
lda ZR+1 ; now limit bound into AY
|
||
|
ldy ZR
|
||
|
jsr pushay ; limit bound on forth stack
|
||
|
ENTER
|
||
|
.addr ORDER::xt ; ensure within range is ordered low->high
|
||
|
.addr WITHIN::xt ; ( test lower upper -- flag )
|
||
|
CODE
|
||
|
jsr popay ; y = FF if within loop term range, $00 if not
|
||
|
tya
|
||
|
beq :+ ; if not within range, go do jump
|
||
|
jmp _SKIP::xt ; otherwise skip
|
||
|
: jmp _JUMP::xt
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0140
|
||
|
; compilation semantics for +LOOP
|
||
|
dword PLOOP,"+LOOP",F_IMMED|F_CONLY
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr _PLOOP::xt
|
||
|
.addr DUP::xt ; dup do-sys
|
||
|
NLIT 4
|
||
|
.addr PLUS::xt ; get target of loop jump
|
||
|
.addr COMMA::xt ; compile as target of loop
|
||
|
.addr COMP_LIT::xt
|
||
|
.addr UNLOOP::xt ; compile in an UNLOOP (skipped by LEAVE)
|
||
|
NLIT 2
|
||
|
.addr PLUS::xt ; add 2 to get address we need to resolve
|
||
|
.addr HERE::xt ; we'll set jump to target HERE
|
||
|
.addr SWAP::xt ; get things into position
|
||
|
.addr STORE::xt ; and resolve all LEAVES
|
||
|
EXIT ; whew!
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1800
|
||
|
; compilation semantics for LOOP
|
||
|
dword LOOP,"LOOP",F_IMMED|F_CONLY
|
||
|
ENTER
|
||
|
.addr COMP_LIT::xt
|
||
|
.word 1
|
||
|
.addr PLOOP::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1800
|
||
|
dword LEAVE,"LEAVE",F_CONLY
|
||
|
pla ; drop loop control vars
|
||
|
pla
|
||
|
pla
|
||
|
pla
|
||
|
pla ; get leave address from return stack
|
||
|
tay
|
||
|
pla
|
||
|
jmp _JUMP::go ; and jump
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1680
|
||
|
dword IX,"I",F_CONLY
|
||
|
ENTER
|
||
|
NLIT 2
|
||
|
.addr RPICK::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.1730
|
||
|
dword JX,"J",F_CONLY
|
||
|
ENTER
|
||
|
NLIT 4
|
||
|
.addr RPICK::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
.if 0
|
||
|
; non-standard
|
||
|
dword KX,"K",F_CONLY
|
||
|
ENTER
|
||
|
NLIT 6
|
||
|
.addr RPICK::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
.endif
|
||
|
|
||
|
; Back to non-loop stuff
|
||
|
|
||
|
; Core ext 6.2.2535
|
||
|
dword BACKSLASH,"\",F_IMMED
|
||
|
ENTER
|
||
|
.addr NIN::xt
|
||
|
.addr FETCH::xt
|
||
|
.addr PIN::xt
|
||
|
.addr STORE::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
|
||
|
; The following words are implemented as no-ops because they are
|
||
|
; inapplicable to this system. They are implemented as JMPs
|
||
|
; so that they can potentially be resolved as deferred words.
|
||
|
|
||
|
; but first, here's where they will all point initially
|
||
|
hword NO_OP,"NO_OP"
|
||
|
NEXT
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0705
|
||
|
; alignment is not required on this platform
|
||
|
dword ALIGN,"ALIGN"
|
||
|
jmp NO_OP
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0706
|
||
|
; alignment is not required on this platform
|
||
|
dword ALIGNED,"ALIGNED"
|
||
|
jmp NO_OP
|
||
|
eword
|
||
|
|
||
|
; Core 6.1.0898
|
||
|
; chars are byte-sized
|
||
|
dword CHARS,"CHARS"
|
||
|
jmp NO_OP
|
||
|
eword
|
||
|
|
||
|
.proc _environmentq
|
||
|
ENTER
|
||
|
.addr TWODROP::xt
|
||
|
.addr FALSE::xt
|
||
|
EXIT
|
||
|
.endproc
|
||
|
|
||
|
; Core 6.1.1345
|
||
|
; ENVIRONMENT? always returns false (unknown) by default
|
||
|
; but implemented as a deferred word
|
||
|
dword ENVIRONMENTQ,"ENVIRONMENT?"
|
||
|
jmp _environmentq
|
||
|
eword
|
||
|
|
||
|
|
||
|
; the following words are not implemented per the Forth 2012 standard
|
||
|
; because they are obsolete. They can be enabled if desired.
|
||
|
.if 0
|
||
|
; Core ext 6.2.2530
|
||
|
dword CCOMPILE,"[COMPILE]",F_CONLY|F_IMMED
|
||
|
ENTER
|
||
|
.addr FIND::xt
|
||
|
.addr COMMA::xt
|
||
|
EXIT
|
||
|
eword
|
||
|
.endif
|
||
|
|
||
|
|
||
|
; must come after all dictionary words
|
||
|
dend
|
||
|
|
||
|
DX_end
|