Apple-2-SW
/
davex-mg-utils
mirror of https://github.com/mgcaret/davex-mg-utils.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
davex-mg-utils/dxforth.s

5313 lines
122 KiB
ArmAsm
Raw Permalink Normal View History

dxforth: experimental Forth interpreter as davex external command, see dxforth.txt
2018-12-12 16:58:23 +00:00
; %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,"