6502/of816
1
0
Fork 0
mirror of https://github.com/mgcaret/of816.git synced 2024-06-01 11:42:08 +00:00
Code Issues Projects Releases Wiki Activity
a02e14e375
of816/asm/forth-dictionary.s

6925 lines
182 KiB
ArmAsm
Raw Normal View History

initial full commit
2019-07-01 17:33:44 +00:00
; Forth Built-in Dictionary
; Note that no primitive words should start with a JSL as the body-modifying words
; such as TO, DEFER!, etc. will assume that they can write to the cell immediately
; following the JSL. This would be bad if they are not supposed to do so.
; of course, this caution doesn't apply to words in ROM that can't be altered
; comments starting with H: define help text to be used if I ever ship a help command
dstart "forth"
.if max_search_order > 0
; ( u -- wid ) search order word list entry by number
hword WLNUM,"WL#"
ENTER
.dword dORDER
.dword SWAP
.dword DUP
ONLIT max_search_order
.dword ULT
.dword _IF
.dword bad
.dword INCR
.dword NAPLUS
EXIT
bad: ONLIT -49
.dword THROW
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( widn ... wid1 n -- ) Set dictionary search order.
initial full commit
2019-07-01 17:33:44 +00:00
dword SET_ORDER,"SET-ORDER"
ENTER
.dword DUP
.dword _IF
.dword empty
.dword DUP ; ( ... widn ... wid1 n n' )
ONLIT 0 ; ( ... widn ... wid1 n n' 1 )
.dword SLT ; ( ... widn ... wid1 n f )
.dword _IF ; ( ... widn ... wid1 n )
.dword dolist
.dword DROP ; ( n -- )
.dword FORTH_WORDLIST ; ( -- wid )
ONLIT 1 ; ( ... wid 1 )
dolist: .dword DUP ; ( ... widn ... wid1 u u' )
ONLIT max_search_order ; ( ... widn ... wid1 u u' u2 )
.dword ULTE ; ( ... widn ... wid1 u f )
.dword _IF ; ( ... widn ... wid1 u )
.dword bad
.dword DUP ; ( ... widn ... wid1 u u' )
.dword dORDER ; ( ... widn ... wid1 u u' c-addr )
.dword STORE ; ( ... widn ... wid1 u )
.dword DECR
ONLIT 0 ; ( ... widn ... wid1 u' 0 )
.dword SWAP ; ( ... widn ... wid1 0 u' )
.dword _DO ; ( ... widn ... wid1 )
JUMP lpdone
lp: .dword IX ; ( ... widn ... wid1 u' )
.dword WLNUM ; ( ... widn ... wid1 c-addr )
.dword STORE
ONLIT -1
.dword _PLOOP
.dword lp
lpdone: .dword UNLOOP
EXIT
bad: ONLIT -49
.dword THROW
empty: .dword dORDER
.dword STORE
EXIT
eword
.endif
.if max_search_order > 0
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- wid ) Return the WID of the wordlist containing system words.
initial full commit
2019-07-01 17:33:44 +00:00
dword FORTH_WORDLIST,"FORTH-WORDLIST"
.else
hword FORTH_WORDLIST,"FORTH-WORDLIST"
.endif
SYSVAR SV_FORTH_WL
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Set the first wordlist in the search order to the system words
initial full commit
2019-07-01 17:33:44 +00:00
dword FORTH,"FORTH"
.if max_search_order > 0
ENTER
.dword FORTH_WORDLIST
.dword TOP_OF_ORDER
EXIT
.else
; no-op if no search-ordering allowed
NEXT
.endif
eword
.if max_search_order > 0
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- wid ) Return the WID of the wordlist for environmental queries.
initial full commit
2019-07-01 17:33:44 +00:00
dword dENVQ_WL,"$ENV?-WL"
.else
hword dENVQ_WL,"$ENV?-WL"
.endif
SYSVAR SV_ENV_WL
eword
; The prior was the absolute minimum search order that is possible, but we will
; not use it directly, "FORTH" will be the minimum. However this will be the root
; of all additional wordlists so that the system can be brought into a usable state
; via FORTH.
; ( -- a-addr ) variable containing location of search order
hword ddORDER,"$$ORDER"
SYSVAR SV_dORDER
eword
; ( -- a-addr ) location of search order stack
hword dORDER,"$ORDER"
ENTER
.dword ddORDER
.dword FETCH
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; ( -- a-addr ) Variable containing current compiler wordlist.
initial full commit
2019-07-01 17:33:44 +00:00
hword dCURRENT,"$CURRENT"
SYSVAR SV_CURRENT
eword
.if max_search_order > 0
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- wid ) Return first wordlist in search order.
initial full commit
2019-07-01 17:33:44 +00:00
dword CONTEXT,"CONTEXT"
.else
hword CONTEXT,"CONTEXT"
.endif
ENTER
.if max_search_order > 0
.dword dORDER
.dword FETCH
.dword QDUP
.dword _IF
.dword empty
.dword DECR
.dword WLNUM
.dword FETCH
EXIT
.endif
empty: .dword dCURRENT
.dword FETCH
EXIT
eword
.if max_search_order > 0
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- wid ) Get WID current compiler wordlist.
initial full commit
2019-07-01 17:33:44 +00:00
dword GET_CURRENT,"GET-CURRENT"
.else
hword GET_CURRENT,"GET-CURRENT"
.endif
ENTER
.dword dCURRENT
.dword FETCH
EXIT
eword
.if max_search_order > 0
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- widn ... wid1 u ) Get dictionary search order.
initial full commit
2019-07-01 17:33:44 +00:00
dword GET_ORDER,"GET-ORDER"
ENTER
.dword dORDER
.dword FETCH
ONLIT 0
.dword _QDO
JUMP lpdone
lp: .dword IX
.dword WLNUM
.dword FETCH
ONLIT 1
.dword _PLOOP
.dword lp
lpdone: .dword UNLOOP
.dword dORDER
.dword FETCH
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; ( wid -- ) Set the first wordlist in the search order.
initial full commit
2019-07-01 17:33:44 +00:00
hword TOP_OF_ORDER,"TOP-OF-ORDER"
ENTER
.dword PtoR
.dword GET_ORDER
.dword QDUP
.dword _IF
.dword default
.dword NIP
.dword RtoP
.dword SWAP
.dword SET_ORDER
EXIT
default: .dword RtoP
ONLIT 1
.dword SET_ORDER
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Fuplicate the first wordlist in the search order.
initial full commit
2019-07-01 17:33:44 +00:00
dword ALSO,"ALSO"
ENTER
.dword GET_ORDER
.dword QDUP
.dword _IFFALSE
.dword :+
.dword GET_CURRENT
.dword ONE
: .dword INCR
.dword OVER
.dword SWAP
.dword SET_ORDER
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Remove the first wordlist in the search order.
initial full commit
2019-07-01 17:33:44 +00:00
dword PREVIOUS,"PREVIOUS"
ENTER
.dword GET_ORDER
.dword QDUP
.dword _IF
.dword noorder
.dword NIP
.dword DECR
.dword SET_ORDER
EXIT
noorder: ONLIT -50
.dword THROW
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( wid -- ) Set the compiler wordlist.
initial full commit
2019-07-01 17:33:44 +00:00
dword SET_CURRENT,"SET-CURRENT"
ENTER
.dword dCURRENT
.dword STORE
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Set the search order to contain only the system wordlist.
initial full commit
2019-07-01 17:33:44 +00:00
dword ONLY,"ONLY"
ENTER
.dword FORTH_WORDLIST
ONLIT 1
.dword SET_ORDER
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Set the search order to contain only the current top of the order.
initial full commit
2019-07-01 17:33:44 +00:00
dword SEAL,"SEAL"
ENTER
.dword CONTEXT
.dword ONE
.dword SET_ORDER
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( wid -- c-addr u ) Return the name of a wordlist, or ^address if no name.
initial full commit
2019-07-01 17:33:44 +00:00
hword WL_NAME,"WL-NAME"
ENTER
.dword DUP
.dword CELLPLUS
.dword FETCH
.dword QDUP
.dword _IF
.dword noname
.dword NIP
.dword rNAME
EXIT
noname: JUMP rNAME_noname1
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Display the current search order and compiler wordlist.
initial full commit
2019-07-01 17:33:44 +00:00
dword ORDER,"ORDER"
ENTER
SLIT "Compiling to: "
.dword TYPE
.dword GET_CURRENT
.dword WL_NAME
.dword TYPE
.dword CR
SLIT "Search order:"
.dword TYPE
.dword CR
.dword GET_ORDER
ONLIT 0
.dword _QDO
JUMP lpdone
lp: .dword WL_NAME
.dword TYPE
.dword CR
ONLIT 1
.dword _PLOOP
.dword lp
lpdone: .dword UNLOOP
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Set the compiler wordlist to the first wordlist in the search order.
initial full commit
2019-07-01 17:33:44 +00:00
dword DEFINITIONS,"DEFINITIONS"
ENTER
.dword CONTEXT
.dword SET_CURRENT
EXIT
eword
.endif
; ( -- cell ) read literal cell from instruction stream, place it on the stack
hword _LIT,"_LIT"
jsr _fetch_ip_cell
PUSHNEXT
eword
; ( -- word ) read literal word from instruction stream, place it on the stack
hword _WLIT,"_WLIT"
jsr _fetch_ip_word
tay
lda #$0000
PUSHNEXT
eword
; ( -- char ) read literal char from instruction stream, place it on the stack
hword _CLIT,"_CLIT"
jsr _fetch_ip_byte
tay
lda #$0000
PUSHNEXT
eword
; ( -- c-addr u ) skip string in instruction stream, place address and len on stack
; read cell-sized <length> from instruction stream, place it on the stack
; place the address of the next cell on the stack
; skip <length> bytes in the instruction stream
hword _SLIT,"_SLIT"
jsr _fetch_ip_cell
sty WR
sta WR+2
jsr _pushay
ldy IP
lda IP+2
iny
bne :+
inc a
: jsr _pushay
jsr _swap
lda IP
clc
adc WR
sta IP
lda IP+2
adc WR+2
sta IP+2
NEXT
eword
; ( -- ) Directly compile a cell literal from IP to [HERE]
; read next cell from instruction stream, compile it into the dictionary
hword _COMP_LIT,"_COMP_LIT"
jsr _fetch_ip_cell
jsr _ccellay
NEXT
eword
; ( -- ) Directly compile a character literal from IP to [HERE]
; read char from instruction stream, compile it into the dictionary
hword _COMP_CLIT,"_COMP_LIT"
jsr _fetch_ip_byte
jsr _cbytea
NEXT
eword
; ( -- ) System initialization
hword ddSYSINIT,"$$SYSINIT"
ENTER
.dword FORTH_WORDLIST ; make sure current wordlist is the Forth wordlist
.dword dCURRENT
.dword STORE
.dword HERE ; set up minimal search order stuff
.dword ddORDER
.dword STORE
ONLIT 0 ; for # of items in order
.dword COMMA
.if max_search_order > 0
ONLIT max_search_order ; now allocate the storage for the search order
.dword CELLS
.dword ALLOT
.endif ; match_search_order
.dword dMEMTOP ; set $HIMEM to $MEMTOP for dynamic allocation
.dword FETCH
.dword dHIMEM
.dword STORE
ONLIT tib_size
.dword ALLOC ; TODO: catch exception
.dword dTIB
.dword STORE
system interface fcode now supported
2019-07-13 08:14:40 +00:00
.if include_fcode
ONLIT SI_GET_FCODE ; See if system wants us to evaluate FCode
.dword dSYSIF
.dword QDUP
.dword _IF
.dword no_fcode ; apparently not
lp: .dword PtoR
.dword RCOPY
.dword FETCH
.dword QDUP
.dword _IF
.dword dn_fcode
.dword ONE
.dword BYTE_LOAD
.dword RtoP
.dword CELLPLUS
JUMP lp
dn_fcode: .dword RDROP
no_fcode:
.endif
initial full commit
2019-07-01 17:33:44 +00:00
NLIT NOOP ; set up STATUS defer.
SLIT "STATUS"
.dword dDEFER
.dword PROTECTED ; make sure it can't be FORGETted
.dword CR ; and say hello
SLIT "OF816 by M.G."
.dword TYPE
.dword CR
EXIT
eword
; ( xt base -- ) execute xt with temporary base
hword TMPBASE,"TMPBASE"
ENTER
.dword BASE
.dword DUP
.dword FETCH
.dword PtoR
.dword STORE
.dword CATCH
.dword RtoP
.dword BASE
.dword STORE
.dword THROW
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Display version information.
initial full commit
2019-07-01 17:33:44 +00:00
dword DOTVERSION,".VERSION"
ENTER
SLIT .concat("OF816 v",VERSION,"/")
.dword TYPE
ONLIT .time
ONLIT UDOT
ONLIT 16
.dword TMPBASE
.if .strlen(PLATFORM) > 0
SLIT .concat("for ", PLATFORM, ", CA65 ", .sprintf("%d.%d",.hibyte(.version),(.version & $F0)/$10))
.else
SLIT ", CA65"
.endif
.dword TYPE
.dword CR
.if include_fcode
SLIT "FCode enabled"
.dword TYPE
.dword CR
.endif
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Reset the system.
initial full commit
2019-07-01 17:33:44 +00:00
dword RESET_ALL,"RESET-ALL"
lda #SI_RESET_ALL
jsl _call_sysif
bcc :+
jmp _throway
: NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Restore system stack pointer and exit Forth.
initial full commit
2019-07-01 17:33:44 +00:00
dword BYE,"BYE"
lda SYS_RSTK
tcs
rtl
eword
; ( n -- ) display exception message
; Display a message associated with exception # n. It first looks to see if there
; is a MESSAGE ( n -- n|0 ) word in the current search order. If there is, it calls it and
; if n2 is nonzero, assumes no message was displayed and proceeds, otherwise we are done.
hword _MESSAGE,"_MESSAGE"
ENTER
SLIT "MESSAGE"
.dword dFIND
.dword _IF
.dword notfound
.dword CATCH
.dword _IFFALSE
.dword exc
.dword QDUP
.dword _IFFALSE
.dword nomsg
EXIT
notfound: .dword TWODROP
nomsg: ONLIT -4
.dword _IFEQUAL
.dword :+
SLIT "Stack u/f"
JUMP dotype
: ONLIT -13
.dword _IFEQUAL
.dword :+
SLIT "Def not found"
JUMP dotype
: ONLIT -10
.dword _IFEQUAL
.dword :+
SLIT "Div by 0"
JUMP dotype
: SLIT "Exception #"
.dword TYPE
.dword DOTD
EXIT
exc: SLIT "Exc. in MESSAGE!"
dotype: .dword TYPE
.dword DROP
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( xt -- xi ... xj n|0 ) Call xt, trap exception, and return it in n.
initial full commit
2019-07-01 17:33:44 +00:00
; catch return stack frame is:
; IP (4), old RSTK_SAVE (2), data SP (2, first out)
dword CATCH,"CATCH"
jsr _popwr ; remove xt for now, throw exception if none given
inc CATCHFLAG
lda IP+2 ; put catch frame on stack
pha ; starting with IP
lda IP
pha
lda RSTK_SAVE ; old saved return stack pointer
pha
phx ; data stack pointer
tsc
sta RSTK_SAVE ; save return stack for later restoration
ldy WR
lda WR+2
jsr _pushay ; push xt back on stack
ENTER
.dword EXECUTE ; execute framed xt
CODE
; no exception if we got here
lda #$0000
sta WR ; exit code will be zero
sta WR+2
pla ; drop old data SP
fixup: pla ; get old RSTK_SAVE
sta RSTK_SAVE
pla
sta IP ; restore previous IP (after catch)
pla
sta IP+2
dec CATCHFLAG
ldy WR
lda WR+2
PUSHNEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n -- ) Throw exception n if n <> 0.
initial full commit
2019-07-01 17:33:44 +00:00
dword THROW,"THROW"
jsr _popay ; get exception # from stack
throway: .if trace
wdm $90
wdm $8f
.endif
cmp #$0000 ; is it zero?
bne :+
cpy #$0000
bne :+
NEXT ; if zero, do nothing
: sty WR ; if not zero, save it
sta WR+2
lda CATCHFLAG ; CATCH active?
beq uncaught ; nope, go handle it
lda RSTK_SAVE ; restore stack pointer to catch frame
tcs
plx ; restore data stack pointer
bra CATCH::fixup ; "return" from CATCH
uncaught: lda #$FFFF ; is negative?
cmp WR+2
bne :+ ; nope, don't check for specifics
lda WR
cmp #.loword(-1) ; ABORT
beq abort
cmp #.loword(-2) ; ABORT"
beq abort
: jsr _stackroom ; make room on data stack if needed
ldy WR
lda WR+2
jsr _pushay ; push exception # back on stack
ENTER ; short routine to display error message
.dword SPACE
.dword _MESSAGE
CODE
jmp __doquit ; and restart with QUIT
abort: ldx STK_TOP ; empty data stack per standard for ABORT
jmp __doquit ; and restart with QUIT
eword
_throway = THROW::throway
; ( -- f ) return true if a CATCH is active
hword CATCHQ,"CATCH?"
ldy CATCHFLAG
lda #$00
PUSHNEXT
eword
; ( f c-addr u -- ) word compiled or executed by ABORT"
; if f is true display c-addr u and execute -2 THROW, otherwise continue execution
hword _ABORTQ,"_ABORT'"
ENTER
.dword ROT
.dword _IF
.dword noabort
.dword CATCHQ
.dword _IF
.dword dotype
.dword TWODROP
.dword _SKIP
dotype: .dword TYPE
fix problem in ABORT" discovered in unit test
2020-01-06 01:23:44 +00:00
;.dword CLEAR
initial full commit
2019-07-01 17:33:44 +00:00
ONLIT -2
.dword THROW
noabort: .dword TWODROP
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: Compilation/Interpretation: ( [text<">] -- ) Execution: ( f -- )
; H: If f is true, display text and execute -2 THROW.
initial full commit
2019-07-01 17:33:44 +00:00
dwordq ABORTQ,"ABORT'",F_IMMED
ENTER
.dword SQ
.dword _SMART
.dword interp
.dword _COMP_LIT
interp: .dword _ABORTQ
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Execute -1 THROW.
initial full commit
2019-07-01 17:33:44 +00:00
dword ABORT,"ABORT"
ENTER
ONLIT -1
.dword THROW
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- addr ) addr = address of the CPU direct page
initial full commit
2019-07-01 17:33:44 +00:00
dword dDIRECT,"$DIRECT"
tdc
tay
lda #$00
PUSHNEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- addr ) addr = top of usable data space
initial full commit
2019-07-01 17:33:44 +00:00
dword dMEMTOP,"$MEMTOP"
ENTER
.dword dDIRECT
ONLIT MEM_TOP
.dword PLUS
EXIT
eword
; H: ( -- u ) u = unused data space accounting for PAD and dynamic allocations
dword UNUSED,"UNUSED"
ENTER
.dword dHIMEM
.dword FETCH
.dword HERE
.dword MINUS
ONLIT 16
.dword MINUS
ONLIT word_buf_size
.dword MINUS
.if pad_size > 0
ONLIT pad_size
.dword MINUS
.endif
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Do nothing.
initial full commit
2019-07-01 17:33:44 +00:00
dword NOOP,"NOOP"
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- u ) u = size of char in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword SCHAR,"/C"
FCONSTANT 1
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- u ) u = size of word in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword SWORD,"/W"
FCONSTANT 2
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- u ) u = size of long in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword SLONG,"/L"
FCONSTANT 4
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- u ) u = size of cell in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword SCELL,"/N"
FCONSTANT 4
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 n -- u2 ) u2 = u1 + n * size of char in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword CAPLUS,"CA+"
ENTER
.dword SCHAR
domath: .dword UMULT
.dword PLUS
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 n -- u2 ) u2 = u1 + n * size of word in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword WAPLUS,"WA+"
ENTER
.dword SWORD
JUMP CAPLUS::domath
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 n -- u2 ) u2 = u1 + n * size of long in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword LAPLUS,"LA+"
ENTER
.dword SLONG
JUMP CAPLUS::domath
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 n -- u2 ) u2 = u1 + n * size of cell in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword NAPLUS,"NA+"
ENTER
.dword SCELL
JUMP CAPLUS::domath
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 -- u2 ) u2 = u1 + size of char in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword CHARPLUS,"CHAR+"
ENTER
.dword SCHAR
.dword PLUS
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 -- u2 ) u2 = u1 + size of cell in bytes.
initial full commit
2019-07-01 17:33:44 +00:00
dword CELLPLUS,"CELL+"
ENTER
.dword SCELL
.dword PLUS
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 * size of char.
initial full commit
2019-07-01 17:33:44 +00:00
dword CHARS,"CHARS"
ENTER
.dword SCHAR
.dword UMULT
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 * size of cell.
initial full commit
2019-07-01 17:33:44 +00:00
dword CELLS,"CELLS"
ENTER
.dword SCELL
.dword UMULT
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u1 -- u2 ) u2 = next aligned address after u1.
initial full commit
2019-07-01 17:33:44 +00:00
dword ALIGNED,"ALIGNED"
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 + size of char.
initial full commit
2019-07-01 17:33:44 +00:00
dword CAINCR,"CA1+"
jmp CHARPLUS::code
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 + size of word.
initial full commit
2019-07-01 17:33:44 +00:00
dword WAINCR,"WA1+"
ENTER
.dword SWORD
.dword PLUS
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 + size of long.
initial full commit
2019-07-01 17:33:44 +00:00
dword LAINCR,"LA1+"
ENTER
.dword SLONG
.dword PLUS
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 + size of cell.
initial full commit
2019-07-01 17:33:44 +00:00
dword NAINCR,"NA1+"
jmp CELLPLUS::code
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 * size of char.
initial full commit
2019-07-01 17:33:44 +00:00
dword SCHARMULT,"/C*"
jmp CHARS::code
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 * size of word.
initial full commit
2019-07-01 17:33:44 +00:00
dword SWORDMULT,"/W*"
ENTER
.dword SWORD
.dword UMULT
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 * size of long.
initial full commit
2019-07-01 17:33:44 +00:00
dword SLONGMULT,"/L*"
ENTER
.dword SLONG
.dword UMULT
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( n1 -- n2 ) n2 = n1 * size of cell.
initial full commit
2019-07-01 17:33:44 +00:00
dword SCELLMULT,"/N*"
jmp CELLS::code
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u -- u1 ... u4 ) u1 ... u4 = bytes of u.
initial full commit
2019-07-01 17:33:44 +00:00
dword LBSPLIT,"LBSPLIT"
jsr _1parm
lda STACKBASE+0,x
ldy STACKBASE+2,x
pha
and #$FF
sta STACKBASE+0,x
stz STACKBASE+2,x
pla
xba
and #$FF
jsr _pusha
tya
and #$FF
jsr _pusha
tya
xba
and #$FF
fix error in lbsplit uncovered by unit tests
2019-12-29 22:36:31 +00:00
tay
lda #$0000
initial full commit
2019-07-01 17:33:44 +00:00
PUSHNEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u -- u1 ... u2 ) u1 ... u2 = words of u.
initial full commit
2019-07-01 17:33:44 +00:00
dword LWSPLIT,"LWSPLIT"
jsr _1parm
ldy STACKBASE+2,x
stz STACKBASE+2,x
lda #$0000
PUSHNEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u -- u1 .. u2 ) u1 .. u2 = bytes of word u.
initial full commit
2019-07-01 17:33:44 +00:00
dword WBSPLIT,"WBSPLIT"
jsr _1parm
stz STACKBASE+2,x
lda STACKBASE+0,x
pha
and #$FF
sta STACKBASE+0,x
pla
xba
and #$FF
tay
lda #$00
PUSHNEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( b.l b2 b3 b.h -- q ) Join bytes into quad.
initial full commit
2019-07-01 17:33:44 +00:00
dword BLJOIN,"BLJOIN"
jsr _4parm
lda STACKBASE+12,x
and #$FF
sta STACKBASE+12,x
lda STACKBASE+8,x
and #$FF
xba
ora STACKBASE+12,x
sta STACKBASE+12,x
lda STACKBASE+4,x
and #$FF
sta STACKBASE+14,x
lda STACKBASE+0,x
and #$FF
xba
ora STACKBASE+14,x
sta STACKBASE+14,x
_3drop: inx
inx
inx
inx
_2drop: inx
inx
inx
inx
_1drop: inx
inx
inx
inx
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( b.l b.h -- w ) Join bytes into word.
initial full commit
2019-07-01 17:33:44 +00:00
dword BWJOIN,"BWJOIN"
jsr _2parm
stz STACKBASE+6,x
lda STACKBASE+4,x
and #$FF
sta STACKBASE+4,x
lda STACKBASE+0,x
and #$FF
xba
ora STACKBASE+4,x
sta STACKBASE+4,x
bra BLJOIN::_1drop
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( w.l w.h -- q ) Join words into quad.
initial full commit
2019-07-01 17:33:44 +00:00
dword WLJOIN,"WLJOIN"
jsr _2parm
lda STACKBASE+0,x
sta STACKBASE+6,x
bra BLJOIN::_1drop
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( w -- w' ) Flip the byte order of w.
initial full commit
2019-07-01 17:33:44 +00:00
dword WBFLIP,"WBFLIP"
jsr _1parm
lda STACKBASE+0,x
xba
sta STACKBASE+0,x
lda STACKBASE+2,x
xba
sta STACKBASE+2,x
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( q -- q' ) Flip the byte order of quad.
initial full commit
2019-07-01 17:33:44 +00:00
dword LBFLIP,"LBFLIP"
jsr _1parm
ldy STACKBASE+0,x
lda STACKBASE+2,x
xba
sta STACKBASE+0,x
tya
xba
sta STACKBASE+2,x
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( q -- q ) Flip the word order of quad.
initial full commit
2019-07-01 17:33:44 +00:00
dword LWFLIP,"LWFLIP"
jsr _1parm
ldy STACKBASE+0,x
lda STACKBASE+2,x
sta STACKBASE+0,x
sty STACKBASE+2,x
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( word -- sign-extended )
initial full commit
2019-07-01 17:33:44 +00:00
dword WSX,"WSX"
jsr _1parm
ldy #$0000
lda STACKBASE+0,x
and #$8000
beq :+
dey
: sty STACKBASE+2,x
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( byte -- sign-extended )
initial full commit
2019-07-01 17:33:44 +00:00
dword BSX,"BSX"
jsr _1parm
ldy #$0000
lda STACKBASE+0,x
and #$80
beq :+
dey
: sty STACKBASE+2,x
tya
and #$FF00
ora STACKBASE+0,x
sta STACKBASE+0,x
NEXT
eword
; ( -- c-addr )
hword dHIMEM,"$HIMEM"
SYSVAR SV_HIMEM
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( u -- c-addr ) Allocate memory from heap.
initial full commit
2019-07-01 17:33:44 +00:00
dword ALLOC,"ALLOC-MEM"
jsr _popxr ; size into XR
jsr _alloc
bcs :+
ldy #.loword(-59)
lda #.hiword(-59)
jmp _throway
: PUSHNEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( c-addr u -- ) Release memory to heap, u is currently ignored.
initial full commit
2019-07-01 17:33:44 +00:00
dword FREE,"FREE-MEM"
jsr _stackincr ; we should really check this (len)
jsr _popwr
jsr _free
bcs :+
ldy #.loword(-60)
lda #.hiword(-60)
jmp _throway
: NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Display heap and temporary string information.
initial full commit
2019-07-01 17:33:44 +00:00
dword DBGMEM,"DEBUG-MEM"
ENTER
.dword CR
SLIT "$CSBUF:"
.dword TYPE
.dword dCSBUF
.dword FETCH
.dword UDOT
SLIT "$SBUF0:"
.dword TYPE
.dword dSBUF0
.dword FETCH
.dword UDOT
SLIT "$SBUF1:"
.dword TYPE
.dword dSBUF1
.dword FETCH
.dword UDOT
.dword dHIMEM ; ( -- $himem )
loop: .dword CR
.dword FETCH ; ( $himem -- u )
.dword DUP ; ( u -- u1 u2 )
.dword dMEMTOP ; ( u1 u2 -- u1 u2 $memtop )
.dword FETCH ; ( u1 u2 $memtop -- u1 u2 u3 )
.dword EQUAL ; ( u1 u2 u3 -- u1 f )
.dword _IFFALSE ; ( u1 f -- u1 )
.dword eom
.dword DUP
ONLIT HDR_SIZE
.dword PLUS
.dword UDOT ; output address
.dword DUP ; ( u1 -- u1 u2 )
.dword DUP ; ( ... -- u1 u2 u3 )
.dword FETCH ; ( u1 u2 u3 -- u1 u2 u3' )
.dword SWAP ; ( u1 u2 u3' -- u1 u3' u2 )
.dword MINUS ; ( u1 u2 u3' -- u1 u4 )
ONLIT HDR_SIZE ; ( u1 u4 -- u1 u4 u5 )
.dword MINUS ; ( u1 u4 u5 -- u1 u6 )
.dword UDOT ; ( u1 u6 -- u1 ) output size
.dword DUP
ONLIT 4
.dword PLUS
.dword WFETCH
ONLIT $8000
.dword LAND
.dword _IF
.dword free
SLIT "used "
JUMP :+
free: SLIT "free "
: .dword TYPE
ONLIT '@'
.dword EMIT
.dword DUP
.dword UDOT ; write header address
ONLIT '>'
.dword EMIT
.dword DUP
.dword FETCH
.dword UDOT
JUMP loop
eom: .dword UDOT
SLIT "$MEMTOP"
.dword TYPE
.dword CR
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- a-addr ) STATE variable, zero if interpreting.
STATE should not be immediate, 1275 7.3.9.2.2 is in error for STATE and IMMEDIATE
2020-01-06 16:23:41 +00:00
dword STATE,"STATE"
initial full commit
2019-07-01 17:33:44 +00:00
SYSVAR SV_STATE
eword
; ( -- u ) variable containing depth of control-flow stack
hword dCSDEPTH,"$CSDEPTH"
SYSVAR SV_dCSDEPTH ; Control-flow stack depth for temporary definitions
eword
; ( -- c-addr ) variable to store HERE during temporary definition creation
hword dSAVEHERE,"$SAVEHERE"
SYSVAR SV_dSAVEHERE ; saved HERE for temporary definitions
eword
; ( -- c-addr ) variable pointing to memory allocated for temporary definition
hword dTMPDEF,"$>TMPDEF"
SYSVAR SV_pTMPDEF ; pointer to memory allocated for temp def
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Enter interpretation state.
initial full commit
2019-07-01 17:33:44 +00:00
dword STATEI,"[",F_IMMED|F_CONLY
ENTER
.dword STATE
.dword OFF
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- ) Enter compilation state.
initial full commit
2019-07-01 17:33:44 +00:00
; immediacy called out in IEEE 1275-1994
dword STATEC,"]",F_IMMED
ENTER
.dword STATE
.dword ON
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- a-addr ) System BASE variable.
initial full commit
2019-07-01 17:33:44 +00:00
dword BASE,"BASE"
SYSVAR SV_BASE
eword
; H: ( ... u -- ... ) call system interface function u
dword dSYSIF,"$SYSIF"
jsr _popay
tya
jsl _call_sysif
bcc :+
jmp _throway
: NEXT
eword
; Raw function needed by line editor
.proc _emit
do_emit: lda #SI_EMIT
jsl _call_sysif
bcc :+
jmp _throway
: rts
.endproc
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( char -- ) Output char.
initial full commit
2019-07-01 17:33:44 +00:00
dword EMIT,"EMIT"
jsr _peekay
tya
and #$FF
cmp #' '
bcc do_emit ; don't count control chars
ldy #SV_NOUT
lda [SYSVARS],y ; increment #OUT
inc a
sta [SYSVARS],y
bne do_emit
iny
iny
lda [SYSVARS],y
inc a
sta [SYSVARS],y
do_emit: jsr _emit
NEXT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( addr u -- ) Output string.
initial full commit
2019-07-01 17:33:44 +00:00
dword TYPE,"TYPE"
jsr _popxr
jsr _popwr
ldy #.loword(do_emit-1)
lda #.hiword(do_emit-1)
jsr _str_op_ay
NEXT
do_emit: jsr _pusha
ENTER
.dword EMIT
CODE
clc
rtl
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- f ) If #LINE >= 20, prompt user to continue and return false if they want to.
initial full commit
2019-07-01 17:33:44 +00:00
dword EXITQ,"EXIT?"
ENTER
.dword NLINE
.dword FETCH
ONLIT 20 ; TODO: replace with variable
.dword UGTE
.dword _IF
.dword nopage
ONLIT 0
.dword NLINE
.dword STORE
SLIT "more? (Y/n)"
.dword TYPE
.dword KEY
.dword CR
.dword LCC
ONLIT 'n'
.dword EQUAL
EXIT
nopage: .dword FALSE
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- addr ) Variable containing the number of lines output.
initial full commit
2019-07-01 17:33:44 +00:00
dword NLINE,"#LINE"
SYSVAR SV_NLINE
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- addr ) variable containing the number of chars output on the current line.
initial full commit
2019-07-01 17:33:44 +00:00
dword NOUT,"#OUT"
SYSVAR SV_NOUT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- addr ) Variable containing offset to the current parsing area of input buffer.
initial full commit
2019-07-01 17:33:44 +00:00
dword PIN,">IN"
SYSVAR SV_PIN
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- addr ) Variable containing number of chars in the current input buffer.
initial full commit
2019-07-01 17:33:44 +00:00
dword NIN,"#IN"
SYSVAR SV_NIN
eword
; H: ( xt -- ) execute xt, regardless of its flags
dword EXECUTE,"EXECUTE"
jsr _popay
RUN
eword
; ( -- ) read a cell from the instruction stream, set the next IP to it
hword _JUMP,"_JUMP"
jsr _fetch_ip_cell
jsr _decay
go: sty IP
sta IP+2
NEXT
eword
; ( -- ) read and discard a cell from the instruction stream
hword _SKIP,"_SKIP"
jsr _fetch_ip_cell
NEXT
eword
; ( -- ) read a cell from the instruction stream; if interpretation state set IP to it
hword _SMART,"_SMART"
.if 1 ; native
ldy #SV_STATE
lda [SYSVARS],y
bne _SKIP::code
iny
iny
lda [SYSVARS],y
bne _SKIP::code
beq _JUMP::code
.else ; mixed
ENTER
.dword STATE
.dword FETCH
CODE
jsr _popay
sty WR
ora WR
beq _JUMP::code
bne _SKIP::code
.endif
eword
; ( -- ) read and discard two cells from the instruction stream
hword _SKIP2,"_SKIP2"
jsr _fetch_ip_cell
bra _SKIP::code
eword
; H: ( n -- ) compile cell n into the dictionary
dword COMMA,","
jsr _popay
jsr _ccellay
NEXT
eword
; H: ( xt -- ) compile xt into the dictionary
; immediacy called out in IEEE 1275-1994
dword COMPILECOMMA,"COMPILE,",F_IMMED
bra COMMA::code
eword
; H: ( n -- ) compile numeric literal n into dictionary, leave n on stack at execution
dword LITERAL,"LITERAL",F_IMMED
jsr _1parm
.if no_fast_lits
ldy #.loword(_LIT)
lda #.hiword(_LIT)
jsr _ccellay ; compile _LIT
bra COMMA::code ; compile actual number
.else
lda STACKBASE+2,x
beq COMMA::code ; compile fast literal
ldy #.loword(_LIT)
lda #.hiword(_LIT)
jsr _ccellay ; compile _LIT
bra COMMA::code ; compile actual number
.endif
eword
; H: ( char -- ) compile char into dictionary
dword CCOMMA,"C,"
jsr _popay
tya
jsr _cbytea
NEXT
eword
; H: ( word -- ) compile word into dictionary
dword WCOMMA,"W,"
jsr _popay
tya
jsr _cworda
NEXT
eword
; H: ( q -- ) compile quad into the dictionary
dword LCOMMA,"L,"
bra COMMA::code
eword
; H: ( u -- u ) align u (no-op in this implementation)
dword ALIGN,"ALIGN"
NEXT
eword
; H: ( n -- ) allocate n bytes in the dictionary
dword ALLOT,"ALLOT"
jsr _popay
pha
tya
clc
adc DHERE
sta DHERE
pla
adc DHERE+2
sta DHERE+2
NEXT
eword
; H: ( c-addr -- n ) fetch cell from c-addr
dword FETCH,"@"
jsr _popwr
fetch2: jsr _wrfetchind
PUSHNEXT
eword
; H: ( c-addr -- n ) fetch cell from c-addr
dword LFETCH,"L@"
bra FETCH::code
eword
.if unaligned_words
; H: ( c-addr -- n ) fetch cell from c-addr
dword LFECTCHU,"UNALIGNED-L@"
bra LFETCH::code
eword
.endif
; H: ( c-addr -- n1 n2 ) fetch two consecutive cells from c-addr
dword TWOFETCH,"2@"
jsr _popwr
Fix 2@/2! discovered in unit testing
2020-01-02 06:00:49 +00:00
jsr _wrplus4
initial full commit
2019-07-01 17:33:44 +00:00
jsr _wrfetchind
jsr _pushay
Fix 2@/2! discovered in unit testing
2020-01-02 06:00:49 +00:00
jsr _wrminus4
initial full commit
2019-07-01 17:33:44 +00:00
bra FETCH::fetch2
eword
; H: ( c-addr -- char ) fetch char from c-addr
dword CFETCH,"C@"
jsr _popwr
fix #1 and #2
2019-07-05 18:10:56 +00:00
sep #SHORT_A
lda [WR]
rep #SHORT_A
initial full commit
2019-07-01 17:33:44 +00:00
and #$00FF
jsr _pusha
NEXT
eword
; H: ( c-addr -- word ) fetch word from c-addr
dword WFETCH,"W@"
jsr _popwr
fix #1 and #2
2019-07-05 18:10:56 +00:00
lda [WR]
initial full commit
2019-07-01 17:33:44 +00:00
jsr _pusha
NEXT
eword
; H: ( c-addr -- n ) fetch sign-extended word from c-addr
dword WFETCHS,"<W@"
fix #1 and #2
2019-07-05 18:10:56 +00:00
ENTER
.dword WFETCH
.dword WSX
EXIT
initial full commit
2019-07-01 17:33:44 +00:00
eword
.if unaligned_words
; H: ( c-addr -- n ) fetch word from c-addr
dword WFECTCHU,"UNALIGNED-W@"
bra WFETCH::code
eword
.endif
; H: ( n c-addr -- ) write cell n to c-addr
dword STORE,"!"
jsr _popwr
store2: jsr _popay
jsr _wrstoreind
NEXT
eword
; H: ( n c-addr -- ) write cell n to c-addr
dword LSTORE,"L!"
bra STORE::code
eword
.if unaligned_words
; H: ( n c-addr -- ) write cell n to c-addr
dword LSTOREU,"UNALIGNED-L!"
bra LSTORE::code
eword
.endif
; H: ( n1 n2 c-addr -- ) write consecutive cells n1 and n2 to c-addr
dword TWOSTORE,"2!"
jsr _popwr
jsr _popay
jsr _wrstoreind
Fix 2@/2! discovered in unit testing
2020-01-02 06:00:49 +00:00
jsr _wrplus4
initial full commit
2019-07-01 17:33:44 +00:00
bra STORE::store2
eword
; H: ( char c-addr -- ) write char n to c-addr
dword CSTORE,"C!"
jsr _popwr
jsr _popay
tya
sep #SHORT_A
fix #1 and #2
2019-07-05 18:10:56 +00:00
sta [WR]
initial full commit
2019-07-01 17:33:44 +00:00
rep #SHORT_A
NEXT
eword
; H: ( word c-addr -- ) write word n to c-addr
dword WSTORE,"W!"
jsr _popwr
jsr _popay
tya
fix #1 and #2
2019-07-05 18:10:56 +00:00
sta [WR]
initial full commit
2019-07-01 17:33:44 +00:00
NEXT
eword
.if unaligned_words
; H: ( word c-addr -- ) write word n to c-addr
dword WSTOREU,"UNALIGNED-W!"
bra WSTORE::code
eword
.endif
; ( n1 addr -- n2 ) swap n1 with n2 at addr
hword CSWAP,"CSWAP"
ENTER
.dword DUP
.dword FETCH
.dword NROT
.dword STORE
EXIT
eword
; H: ( n1 -- n1 n2 ) n2 = n1
dword DUP,"DUP"
jsr _peekay
PUSHNEXT
eword
; H: ( n -- n ) if n = 0, else ( n1 -- n1 n2 ) n2 = n1
dword QDUP,"?DUP"
jsr _peekay
cmp #$00
bne :+
cpy #$00
bne :+
NEXT
: PUSHNEXT
eword
; H: ( n -- ) (R: -- n )
; must be primitive
dword PtoR,">R"
jsr _popay
pha
phy
NEXT
eword
; H: ( n1 n2 -- ) (R: -- n1 n2 )
; must be primitive
dword TWOPtoR,"2>R"
jsr _swap
jsr _popay
pha
phy
bra PtoR::code
eword
; H: ( x1 ... xn n -- n ) ( R: x1 ... xn -- )
; must be primitive
dword NPtoR,"N>R"
jsr _popay
sty YR
sty YR+2
cpy #$00
beq done
: jsr _popay
pha
phy
dec YR
bne :-
done: lda #$00
ldy YR+2
PUSHNEXT
eword
; H: ( R: n -- ) ( -- n )
; must be primitive
dword RtoP,"R>"
ply
pla
PUSHNEXT
eword
; H: ( R: n1 n2 -- ) ( -- n1 n2 )
; must be primitive
dword TWORtoP,"2R>"
ply
pla
jsr _pushay
ply
pla
jsr _pushay
jsr _swap
NEXT
eword
; H: ( R: x1 ... xn -- ) ( n -- x1 ... xn n )
dword NRtoP,"NR>"
jsr _popay
sty YR
sty YR+2
cpy #$00
beq done
: ply
pla
jsr _pushay
dec YR
bne :-
done: lda #$00
ldy YR+2
PUSHNEXT
eword
; H: ( R: n -- n ) ( -- n )
dword RCOPY,"R@"
lda 1,S
tay
lda 3,S
PUSHNEXT
eword
; H: ( n -- n ) ( R: -- n )
dword COPYR,">R@"
jsr _peekay
pha
phy
NEXT
eword
; H: ( R: n1 n2 -- n1 n2 ) ( -- n1 n2 )
dword TWORCOPY,"2R@"
lda 5,S
tay
lda 7,S
jsr _pushay
bra RCOPY::code
eword
; H: ( R: n -- )
dword RDROP,"RDROP"
pla
pla
NEXT
eword
; H: ( R: n -- n' ) n' = n + 1
; increment item on return stack
dword RINCR,"R+1"
lda 1,s
inc a
sta 1,s
bne :+
lda 3,s
inc a
sta 3,s
: NEXT
eword
; H: ( n1 -- n2 ) n2 = n1th cell in return stack
hword RPICK,"RPICK"
jsr _popwr
tya
asl
asl
sta WR
tsc
sec ; +1
adc WR
sta WR
stz WR+2
ldy #$02
lda [WR],y
pha
dey
dey
lda [WR],y
tay
pla
NEXT
eword
; ( -- n ) n = cell-extended 24-bit address
; pluck the machine return address underneath the Forth return address
; on the return stack and place it on the data stack. Used by DOES>
hword RPLUCKADDR,"RPLUCKADDR"
ply ; save top of stack address
sty WR
pla
sta WR+2
sep #SHORT_A
.a8
ply ; pull desired address
pla
rep #SHORT_A
.a16
and #$00FF
jsr _pushay
lda WR+2 ; put back top of stack
pha
ldy WR
phy
NEXT
eword
; H: ( n1 n2 -- n2 n1 )
dword SWAP,"SWAP"
jsr _swap
NEXT
eword
; H: ( n1 -- )
dword DROP,"DROP"
jsr _stackincr
NEXT
eword
; H: ( n1 n2 n3 -- )
dword THREEDROP,"3DROP"
jsr _stackincr
save a few bytes
2020-01-05 01:31:32 +00:00
twodrop: jsr _stackincr
initial full commit
2019-07-01 17:33:44 +00:00
jsr _stackincr
NEXT
eword
save a few bytes
2020-01-05 01:31:32 +00:00
; H: ( n1 n2 -- )
dword TWODROP,"2DROP"
bra THREEDROP::twodrop
eword
initial full commit
2019-07-01 17:33:44 +00:00
; H: ( n1 ... nx -- ) empty stack
dword CLEAR,"CLEAR"
ldx STK_TOP
NEXT
eword
; H: ( n1 ... nx -- n1 ... nx x )
dword DEPTH,"DEPTH"
stx WR
lda STK_TOP
sec
sbc WR
lsr
lsr
tay
lda #$0000
PUSHNEXT
eword
; H: ( n1 n2 -- n1 n2 n3 ) n3 = n1
dword OVER,"OVER"
jsr _over
NEXT
eword
; H: ( x1 ... xn u -- x1 ... xn x(n-u) )
dword PICK,"PICK"
jsr _2parm
lda STACKBASE+0,x
asl
asl
sta WR
txa
clc
adc WR
phx
tax
ldy STACKBASE+4,x
lda STACKBASE+6,x
plx
sty STACKBASE+0,x
sta STACKBASE+2,x
NEXT
eword
; H: ( -- ) display stack contents
dword DOTS,".S"
ENTER
ONLIT '{'
.dword EMIT
.dword SPACE
.dword DEPTH
.dword DUP
.dword DOT
ONLIT ':'
.dword EMIT
.dword SPACE
.dword DUP
.dword _IF
.dword done
lp: .dword DECR
.dword DUP
.dword PtoR
.dword PICK
.dword DOT
.dword RtoP
.dword DUP
.dword _IFFALSE
.dword lp
done: .dword DROP
ONLIT '}'
.dword EMIT
EXIT
eword
; H: ( n1 n2 -- n2 )
dword NIP,"NIP"
jsr _2parm
lda STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+2,x
sta STACKBASE+6,x
inx
inx
inx
inx
NEXT
eword
; H: ( n1 n2 -- n3 n1 n2 ) n3 = n2
dword TUCK,"TUCK"
ENTER
.dword SWAP
.dword OVER
EXIT
eword
; H: ( n1 n2 n3 -- n3 )
2NIP not the same as other Forths, rename and make headerless
2020-01-08 20:25:46 +00:00
hword NIPTWO,"NIP2"
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword PtoR
.dword TWODROP
.dword RtoP
EXIT
eword
; H: ( n1 n2 -- n1 n2 n3 n4 ) n3 = n1, n4 = n2
dword TWODUP,"2DUP"
jsr _over
jsr _over
NEXT
eword
; H: ( n1 n2 n3 -- n1 n2 n3 n4 n5 n6 ) n4 = n1, n5 = n2, n6 = n3
dword THREEDUP,"3DUP"
ENTER
Fix 3DUP bug found by unit testing
2019-12-29 06:52:12 +00:00
ONLIT 2
initial full commit
2019-07-01 17:33:44 +00:00
.dword PICK
Fix 3DUP bug found by unit testing
2019-12-29 06:52:12 +00:00
ONLIT 2
initial full commit
2019-07-01 17:33:44 +00:00
.dword PICK
Fix 3DUP bug found by unit testing
2019-12-29 06:52:12 +00:00
ONLIT 2
initial full commit
2019-07-01 17:33:44 +00:00
.dword PICK
EXIT
eword
.proc _rot
ldy STACKBASE+10,x
lda STACKBASE+6,x
sta STACKBASE+10,x
lda STACKBASE+2,x
sta STACKBASE+6,x
sty STACKBASE+2,x
ldy STACKBASE+8,x
lda STACKBASE+4,x
sta STACKBASE+8,x
lda STACKBASE+0,x
sta STACKBASE+4,x
sty STACKBASE+0,x
rts
.endproc
; H: ( n1 n2 n3 -- n2 n3 n1 )
dword ROT,"ROT"
.if 1 ; native
jsr _3parm
jsr _rot
NEXT
.else ; secondary
ENTER
.dword PtoR
.dword SWAP
.dword RtoP
.dword SWAP
EXIT
.endif
eword
; H: ( n1 n2 n3 -- n3 n1 n2 )
dword NROT,"-ROT"
.if 1 ; native
jsr _3parm
ldy STACKBASE+2,x
lda STACKBASE+6,x
sta STACKBASE+2,x
lda STACKBASE+10,x
sta STACKBASE+6,x
sty STACKBASE+10,x
ldy STACKBASE+0,x
lda STACKBASE+4,x
sta STACKBASE+0,x
lda STACKBASE+8,x
sta STACKBASE+4,x
sty STACKBASE+8,x
NEXT
.else ; secondary
ENTER
.dword ROT
.dword ROT
EXIT
.endif
eword
; H: ( xu ... x0 u -- xu-1 .. x0 xu )
dword ROLL,"ROLL"
jsr _popxr ; put roll depth into XR
lda XR ; number of items - 1 that we are moving
beq done ; if none, GTFO
asl ; to see if enough room on stack
asl
sta XR+2 ; number of cells we are moving
txa
adc XR+2
cmp STK_TOP
bcc :+
jmp _stku_err
: stx WR ; save SP
tax ; change SP to xu
lda STACKBASE+2,x ; save xu
pha
lda STACKBASE+0,x
pha
lp: dex ; move to next-toward-top entry
dex
dex
dex
lda STACKBASE+2,x ; copy this entry to the one below
sta STACKBASE+6,x
lda STACKBASE+0,x
sta STACKBASE+4,x
cpx WR ; are we done?
beq :+
bcs lp
: pla ; finally put xu on top
sta STACKBASE+0,x
pla
sta STACKBASE+2,x
done: NEXT
eword
; H: ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
dword TWOSWAP,"2SWAP"
ENTER
.dword PtoR
.dword NROT
.dword RtoP
.dword NROT
EXIT
eword
; H: ( x1 x2 x3 x4 -- x1 x2 x3 x4 x5 x6 ) x5 = x1, x6 = x2
dword TWOOVER,"2OVER"
ENTER
.dword TWOPtoR
.dword TWODUP
.dword TWORtoP
.dword TWOSWAP
EXIT
eword
; H: ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
dword TWOROT,"2ROT"
ENTER
.dword TWOPtoR
.dword TWOSWAP
.dword TWORtoP
.dword TWOSWAP
EXIT
eword
; H: ( c-addr -- ) store all zero bits to cell at c-addr
dword OFF,"OFF"
jsr _popwr
lda #$0000
onoff: tay
jsr _wrstoreind
NEXT
eword
; H: ( c-addr -- ) store all one bits to cell at c-addr
dword ON,"ON"
jsr _popwr
lda #$FFFF
bra OFF::onoff
eword
; H: ( -- false ) false = all zero bits
dword FALSE,"FALSE"
lda #$0000
tay
PUSHNEXT
eword
; H: ( -- true ) true = all one bits
dword TRUE,"TRUE"
lda #$FFFF
tay
PUSHNEXT
eword
; small assembly routine common to zero comparisons
.proc _zcmpcom
jsr _1parm
ldy #$0000
lda STACKBASE+2,x
rts
.endproc
; H: ( n -- f ) f = true if x is zero, false if not
dword ZEROQ,"0="
jsr _zcmpcom
ora STACKBASE+0,x
bne :+
dey
st: jmp _cmpstore
eword
_cmpstore2 = ZEROQ::st
; H: ( n -- f ) f = false if x is zero, true if not
dword ZERONEQ,"0<>"
jsr _zcmpcom
ora STACKBASE+0,x
beq _cmpstore2
dey
: bra _cmpstore2
eword
; H: ( n -- f ) f = true if x > 0, false if not
dword ZEROGT,"0>"
jsr _zcmpcom
bmi _cmpstore2
ora STACKBASE+0,x
beq _cmpstore2
dey
bra _cmpstore2
eword
; H: ( n -- f ) f = true if x >= 0, false if not
dword ZEROGTE,"0>="
jsr _zcmpcom
bmi _cmpstore2
dey
bra _cmpstore2
eword
; H: ( n -- f ) f = true if x < 0, false if not
dword ZEROLT,"0<"
jsr _zcmpcom
bpl _cmpstore
dey
bra _cmpstore
eword
; H: ( n -- f ) f = true if x <= 0, false if not
dword ZEROLTE,"0<="
jsr _zcmpcom
bmi :+
ora STACKBASE+0,x
bne _cmpstore
: dey
bra _cmpstore
eword
; H: ( n1 n2 -- f ) f = true if n1 = n2, false if not
dword EQUAL,"="
jsr _ucmpcom
bne _2cmpstore
dey
bra _2cmpstore
eword
; H: ( n1 n2 -- f ) f = true if n1 <> n2, false if not
dword NOTEQUAL,"<>"
jsr _ucmpcom
beq _2cmpstore
dey
bra _2cmpstore
eword
; H: ( u1 u2 -- f ) f = true if u1 < u2, false if not
dword ULT,"U<"
jsr _ucmpcom
bcs _2cmpstore
dey
bra _2cmpstore
eword
; H: ( u1 u2 -- f ) f = true if u1 <= u2, false if not
dword ULTE,"U<="
jsr _ucmpcom
beq :+
bcs _2cmpstore
: dey
bra _2cmpstore
eword
; more comparison helper routines
.proc _2cmpstore
inx
inx
inx
inx
; fall-through
.endproc
.proc _cmpstore
sty STACKBASE+0,x
sty STACKBASE+2,x
NEXT
.endproc
; H: ( u1 u2 -- f ) f = true if u1 > u2, false if not
dword UGT,"U>"
jsr _ucmpcom
beq _2cmpstore
bcc _2cmpstore
dey
bra _2cmpstore
eword
; H: ( u1 u2 -- f ) f = true if u1 >= u2, false if not
dword UGTE,"U>="
jsr _ucmpcom
bcc _2cmpstore
dey
bra _2cmpstore
eword
; H: ( n1 n2 -- f ) f = true if n1 < n2, false if not
dword SLT,"<"
jsr _scmpcom
bcs _2cmpstore
dey
bra _2cmpstore
eword
; H: ( n1 n2 -- f ) f = true if n1 <= n2, false if not
dword SLTE,"<="
jsr _scmpcom
beq :+
bcs _2cmpstore
: dey
bra _2cmpstore
eword
; H: ( n1 n2 -- f ) f = true if n1 > n2, false if not
dword SGT,">"
jsr _scmpcom
beq _2cmpstore
bcc _2cmpstore
dey
bra _2cmpstore
eword
; H: ( n1 n2 -- f ) f = true if n1 >= n2, false if not
dword SGTE,">="
jsr _scmpcom
beq :+
bcc _2cmpstore
: dey
bra _2cmpstore
eword
; H: ( n1 n2 -- n1|n2 ) return the greater of n1 or n2
dword MAX,"MAX"
jsr _scmpcom
bcs drop
optimize MAX/MIN a bit
2019-12-29 20:49:07 +00:00
swap: jsr _swap
initial full commit
2019-07-01 17:33:44 +00:00
drop: inx
inx
inx
inx
NEXT
eword
; H: ( n1 n2 -- n1|n2 ) return the smaller of n1 or n2
dword MIN,"MIN"
jsr _scmpcom
optimize MAX/MIN a bit
2019-12-29 20:49:07 +00:00
bcc MAX::drop
bra MAX::swap
initial full commit
2019-07-01 17:33:44 +00:00
eword
; common routine for unsigned comparisons
.proc _ucmpcom
jsr _2parm
ldy #$0000
lda STACKBASE+6,x
cmp STACKBASE+2,x
bne :+
lda STACKBASE+4,x
cmp STACKBASE+0,x
: rts
.endproc
; common routine for signed comparisons
.proc _scmpcom
jsr _2parm
ldy #$0000
jmp _stest32
.endproc
; ( c-addr -- ) set dictionary pointer to c-addr
hword toHERE,"->HERE"
jsr _popay
sty DHERE
sta DHERE+2
NEXT
eword
; H: ( -- c-addr ) return dictionary pointer
dword HERE,"HERE"
ldy DHERE
lda DHERE+2
PUSHNEXT
eword
; ( -- c-addr ) return address of last definition in current vocabulary
; non-standard
dword LAST,"LAST"
ENTER
.dword GET_CURRENT
.dword FETCH
EXIT
eword
hword dCURDEF,"$CURDEF"
SYSVAR SV_dCURDEF
eword
; ( -- c-addr ) return address of $OLDHERE system variable
hword dOLDHERE,"$OLDHERE"
SYSVAR SV_OLDHERE
eword
; ( -- c-addr ) return HERE address prior to starting current definition
; used by PATCH to forget partial definiton when uncaught exception occurs
hword OLDHERE,"OLDHERE"
ENTER
.dword dOLDHERE
.dword FETCH
EXIT
eword
; ( -- ) exit current definition
dword DEXIT,"EXIT",F_CONLY
jmp _exit_next
eword
; ( n -- ) read cell from instruction stream, discard if n is true, set IP if false
; word compiled by IF
hword _IF,"_IF"
jsr _popay
ora #$0000
bne :+
tya
bne :+
jmp _JUMP::code
: jmp _SKIP::code
eword
; ( n -- ) read cell from instruction stream, discard if n is false, set IP if true
hword _IFFALSE,"_IFFALSE"
jsr _popay
ora #$0000
bne :+
tya
bne :+
jmp _SKIP::code
: jmp _JUMP::code
eword
; ( x1 x2 -- x1 ) read cell from instruction stream, discard if x1 = x2, set IP if false
; saves some space in hand-coded routines that need CASE-like construction such as
; _MESSAGE
hword _IFEQUAL,"_IFEQUAL"
jsr _popay
cmp STACKBASE+2,x
bne :+
tya
cmp STACKBASE+0,x
bne :+
jmp _SKIP::code
: jmp _JUMP::code
eword
; ( -- ) throw exception -22, control structure mismatch
; used for unresolved forward references
hword _CONTROL_MM,"_CONTROL_MM"
ldy #.loword(-22)
lda #.hiword(-22)
jmp _throway
eword
; H: ( C: orig ) ( E: -- ) jump ahead as resolved by e.g. THEN
dword AHEAD,"AHEAD",F_IMMED|F_CONLY|F_TEMPD
ENTER
.dword _COMP_LIT
.dword _JUMP
.dword HERE
.dword _COMP_LIT
.dword _CONTROL_MM
EXIT
eword
; H: ( C: if-sys ) ( E: n -- ) begin IF ... ELSE ... ENDIF
dword IF,"IF",F_IMMED|F_CONLY|F_TEMPD
ENTER
.dword _COMP_LIT
.dword _IF ; compile _IF
.dword HERE ; save to resolve later
.dword _COMP_LIT
.dword _CONTROL_MM ; compile unresolved
EXIT
eword
; H: ( C: if-sys -- else-sys ) ( E: -- ) ELSE clause of IF ... ELSE ... THEN
dword ELSE,"ELSE",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _JUMP
.dword HERE ; to be resolved later
.dword _COMP_LIT
.dword _CONTROL_MM
.dword SWAP ; put IF's unresolved address in place
.dword HERE ; IF's false branch goes here
.dword SWAP
.dword STORE ; resolve IF
EXIT
eword
; H: ( C: if-sys|else-sys -- ) ( E: -- )
dword THEN,"THEN",F_IMMED|F_CONLY
ENTER
.dword HERE ; IF or ELSE branch goes here
.dword SWAP
.dword STORE ; resolve IF or ELSE
.dword dTEMPSEMIQ ; see if we need to end a temporary def
EXIT
eword
; H: ( n1 n2 -- n1+n2 n1 )
dword BOUNDS,"BOUNDS"
jsr _swap
lda STACKBASE+0,x
clc
adc STACKBASE+4,x
sta STACKBASE+4,x
lda STACKBASE+2,x
adc STACKBASE+6,x
sta STACKBASE+6,x
NEXT
eword
; H: ( C: -- dest ) ( E: -- ) start a BEGIN loop
; BEGIN is basically an immediate HERE
dword BEGIN,"BEGIN",F_IMMED|F_CONLY|F_TEMPD
jmp HERE::code ; dest on stack
eword
; H: ( C: dest -- orig dest ) ( E: x -- ) WHILE clause of BEGIN...WHILE...REPEAT loop
dword WHILE,"WHILE",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _IF
.dword HERE ; ( dest -- dest orig )
.dword SWAP ; ( dest orig -- orig dest )
.dword _COMP_LIT
.dword _CONTROL_MM
EXIT
eword
; H: ( C: dest -- ) ( R: x -- ) UNTIL clause of BEGIN...UNTIL loop
dword UNTIL,"UNTIL",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _IF
.dword COMMA
.dword dTEMPSEMIQ ; see if we need to end a temporary def
EXIT
eword
; H: ( C: orig dest -- ) (R: -- ) resolve orig and dest, repeat BEGIN loop
dword REPEAT,"REPEAT",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _JUMP
.dword COMMA
.dword HERE
.dword SWAP
.dword STORE
.dword dTEMPSEMIQ ; see if we need to end a temporary def
EXIT
eword
; H: ( C: dest -- ) ( R: -- ) resolve dest, jump to BEGIN
dword AGAIN,"AGAIN",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _JUMP
.dword COMMA
.dword dTEMPSEMIQ ; see if we need to end a temporary def
EXIT
eword
; H: ( n1|u1 n2|u2 n3|u3 -- f ) f = true if n2|u2 <= n1|u1 < n3|u3, false otherwise
dword WITHIN,"WITHIN"
ENTER
.dword OVER ; ( n1 n2 n3 -- n1 n2 n3 n2' )
.dword MINUS ; ( n1 n2 n3 n2' -- n1 n2 n4 )
.dword PtoR ; ( n1 n2 n4 -- n1 n2 ) ( R: -- n4 )
.dword MINUS ; ( n1 n2 -- n5 )
.dword RtoP ; ( n5 -- n5 n4 )
.dword ULT ; ( n5 n4 -- f )
EXIT
eword
; H: ( n1|u1 n2|u2 n3|u3 -- f ) f = true if n2|u2 <= n1|u1 <= n3|u3, false otherwise
dword BETWEEN,"BETWEEN"
ENTER
.dword INCR
.dword WITHIN
EXIT
eword
; ( limit start -- ) ( R: -- loop-sys )
; Run-time semantics for DO
resolve #7
2020-01-06 05:53:07 +00:00
; loop-sys = ( -- leave-IP index limit )
initial full commit
2019-07-01 17:33:44 +00:00
hword _DO,"_DO"
jsr _2parm
lda IP+2 ; put IP on stack for LEAVE target
pha
lda IP
pha
jsr _popay ; index
pha
phy
jsr _popay ; limit
pha
phy
jmp _SKIP2::code ; skip LEAVE target (usually a _JUMP)
eword
; ( limit start -- ) ( R: -- loop-sys )
; Run-time semantics for ?DO
hword _QDO,"_QDO"
jsr _2parm
lda IP+2 ; put IP on stack for LEAVE target
pha
lda IP
pha
jsr _popay ; index
pha
phy
jsr _popay ; limit
pha
phy
lda 1,s
cmp 5,s
bne doloop
lda 3,s
cmp 7,s
bne doloop
NEXT ; leave immediately
doloop: jmp _SKIP2::code ; enter loop
eword
; H: Compilation: ( -- ) ( R: -- do-sys )
; H: Execution: ( limit start -- ) begin DO loop
dword DO,"DO",F_IMMED|F_CONLY|F_TEMPD
ENTER
.dword _COMP_LIT
.dword _DO ; compile execution semantics
qdo: .dword HERE ; do-sys
.dword _COMP_LIT
.dword _JUMP ; LEAVE resumes execution here
.dword _COMP_LIT
.dword _CONTROL_MM ; LOOP/+LOOP will jump to do-sys+4, after this cell
EXIT
eword
; H: Compilation: ( -- ) ( R: -- do-sys )
; H: Execution: ( limit start -- ) begin DO loop, skip if limit=start
dword QDO,"?DO",F_IMMED|F_CONLY|F_TEMPD
ENTER
.dword _COMP_LIT
.dword _QDO
JUMP DO::qdo
eword
; H: ( -- ) ( R: loop-sys -- ) remove loop parameters from stack
dword UNLOOP,"UNLOOP",F_CONLY
pla ; drop limit
pla
pla ; drop index
pla
pla ; drop leave-IP
pla
NEXT
eword
; run-time semantics for +LOOP
; With ( i -- ) and ( R: index(5,7) limit(1,3) -- index' limit )
; if new index in termination range, exit va _SKIP, otherwise via _JUMP
; stack-relative addressing is very helpful here
; WR will contain the limit, XR will contain the limit plus the loop increment
; We then see if the loop index is between them and if so we terminate the loop
hword _PLOOP,"_+LOOP"
jsr _1parm
lda 5,s ; Compute new index low byte
clc
adc STACKBASE+0,x ; increment low byte
sta 5,s ; write it back
lda 7,s ; new index high byte
adc STACKBASE+2,x ; increment high byte
sta 7,s ; write it back
jsr _stackdecr ; make some room on stack
jsr _stackdecr
lda 1,s ; compute termination bounds
sta STACKBASE+4,x
clc
adc STACKBASE+8,x
sta STACKBASE+0,x
lda 3,s
sta STACKBASE+6,x
adc STACKBASE+10,x
sta STACKBASE+2,x
lda 5,s ; finally, write new index into third stack entry
sta STACKBASE+8,x
lda 7,s
sta STACKBASE+10,x
ENTER
.dword TWODUP
.dword MAX
.dword PtoR
.dword MIN
.dword RtoP
.dword WITHIN
CODE
lda STACKBASE+0,x
ora STACKBASE+2,x
php
inx
inx
inx
inx
plp
beq :+
jmp _SKIP::code
: jmp _JUMP::code
eword
; H: Compilation: ( C: do-sys -- )
; H: Execution: ( u|n -- ) add u|n to loop index and continue loop if within bounds
dword PLOOP,"+LOOP",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT ; compile execution semantics
.dword _PLOOP
.dword DUP ; ( loop-sys -- loop-sys loop-sys' )
ONLIT 8 ; two cells
.dword PLUS ; ( loop-sys loop-sys' -- loop-sys loop-sys'' ) get target of loop jump
.dword COMMA ; ( loop-sys loop-sys'' -- loop-sys ) and compile as target of _PLOOP
.dword HERE ; ( loop-sys -- loop-sys t )
resolve #7
2020-01-06 05:53:07 +00:00
.dword SWAP ; ( loop-sys t -- t loop-sys )
initial full commit
2019-07-01 17:33:44 +00:00
.dword _COMP_LIT ; compile in an UNLOOP
.dword UNLOOP
ONLIT 4 ; one cell
.dword PLUS ; get address to resolve
.dword STORE ; and resolve all the leaves
.dword dTEMPSEMIQ ; see if we need to end a temporary def
EXIT
eword
; H: Compilation: ( C: do-sys -- )
; H: Execution: ( -- ) add 1 to loop index and continue loop if within bounds
dword LOOP,"LOOP",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword ONE
.dword PLOOP
EXIT
eword
; H: ( -- ) exit loop
dword LEAVE,"LEAVE",F_CONLY
lda 9,s
tay
lda 11,s
jmp _JUMP::go
eword
; H: ( f -- ) exit loop if f is nonzero
dword QLEAVE,"?LEAVE",F_CONLY
jsr _popay
ora #$0000
bne LEAVE::code
tya
bne LEAVE::code
NEXT
eword
; H: ( -- n ) copy inner loop index to stack
dword IX,"I",F_CONLY
lda 5,s
tay
lda 7,s
PUSHNEXT
eword
; H: ( -- n ) copy second-inner loop index to stack
dword JX,"J",F_CONLY
Fix J (and optional K) problem discovered in unit tests
2020-01-06 00:18:27 +00:00
lda 17,s
initial full commit
2019-07-01 17:33:44 +00:00
tay
Fix J (and optional K) problem discovered in unit tests
2020-01-06 00:18:27 +00:00
lda 19,s
initial full commit
2019-07-01 17:33:44 +00:00
PUSHNEXT
eword
.if 0
; H: ( -- n ) copy third-inner loop index to stack
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword KX,"K",F_CONLY ; noindex
Fix J (and optional K) problem discovered in unit tests
2020-01-06 00:18:27 +00:00
lda 29,s
initial full commit
2019-07-01 17:33:44 +00:00
tay
Fix J (and optional K) problem discovered in unit tests
2020-01-06 00:18:27 +00:00
lda 31,s
initial full commit
2019-07-01 17:33:44 +00:00
PUSHNEXT
eword
.endif
; H: Compilation: ( R: -- case-sys ) start a CASE...ENDCASE structure
; H: Execution: ( -- )
dword CASE,"CASE",F_IMMED|F_CONLY|F_TEMPD
ENTER
.dword _COMP_LIT
.dword _SKIP2 ; compile execution semantics
.dword HERE ; case-sys
.dword _COMP_LIT
.dword _JUMP ; ENDOF resumes execution here
.dword _COMP_LIT ; compile unresolved
.dword _CONTROL_MM
EXIT
eword
; ( n1 n2 -- n1 ) run-time semantics of OF
; test against CASE value, SKIP if match
; otherwise JUMP (to cell after ENDOF)
hword _OF,"_OF"
jsr _2parm
lda STACKBASE+4,x
cmp STACKBASE+0,x
bne nomatch
lda STACKBASE+6,x
cmp STACKBASE+2,x
bne nomatch
jsr _stackincr ; drop test value
jsr _stackincr ; and value being tested
jmp _SKIP::code ; and skip jump target
nomatch: jsr _stackincr ; drop test value
jmp _JUMP::code ; go to jump target
eword
; H: Compilation: ( case-sys -- case-sys of-sys ) begin an OF...ENDOF structure
; H: Execution: ( x1 x2 -- | x1 ) execute OF clause if x1 = x2, leave x1 on stack if not
dword OF,"OF",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _OF
.dword HERE ; of-sys
.dword _COMP_LIT ; compile unresolved
.dword _CONTROL_MM
EXIT
eword
; H: Compilation; ( case-sys of-sys -- case-sys ) conclude an OF...ENDOF structure
; H: Execution: Continue execution at ENDCASE of case-sys
dword ENDOF,"ENDOF",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT ; compile a jump
.dword _JUMP
.dword OVER ; copy case-sys
.dword COMPILECOMMA ; which is the jump target
.dword HERE ; unmatched OF jumps here
.dword SWAP
.dword STORE ; resolve of-sys
EXIT
eword
; H: Compilation: ( case-sys -- ) conclude a CASE...ENDCASE structure
; H: Execution: ( | n -- ) continue execution, dropping n if no OF matched
dword ENDCASE,"ENDCASE",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT ; compile drop value under test
.dword DROP
.dword HERE ; case-sys jump goes here
.dword SWAP
.dword CELLPLUS
.dword STORE ; resolve case-sys
.dword dTEMPSEMIQ ; see if we need to end a temporary def
EXIT
eword
; H: ( -- ) store 16 to BASE
dword HEX,"HEX"
ENTER
ONLIT 16
.dword BASE
.dword STORE
EXIT
eword
; H: ( -- ) store 10 to BASE
dword DECIMAL,"DECIMAL"
ENTER
ONLIT 10
.dword BASE
.dword STORE
EXIT
eword
; H: ( -- ) store 2 to BASE
dword BINARY,"BINARY"
ENTER
ONLIT 2
.dword BASE
.dword STORE
EXIT
eword
; H: ( -- ) store 8 to BASE
dword OCTAL,"OCTAL"
ENTER
ONLIT 8
.dword BASE
.dword STORE
EXIT
eword
; H: ( n -- n' ) increment top stack item
dword INCR,"1+"
jsr _1parm
doinc: inc STACKBASE+0,x
bne :+
inc STACKBASE+2,x
: NEXT
eword
; H: ( n -- n' ) decrement top stack item
dword DECR,"1-"
jsr _1parm
lda STACKBASE+0,x
bne :+
dec STACKBASE+2,x
: dec STACKBASE+0,x
NEXT
eword
; H: ( n -- n' ) increment top stack item by 2
dword TWOINCR,"2+"
jsr _1parm
lda STACKBASE+0,x
clc
adc #$02
sta STACKBASE+0,x
bcc :+
inc STACKBASE+2,x
: NEXT
eword
; H: ( n -- n' ) decrement top stack item by 2
dword TWODECR,"2-"
jsr _1parm
lda STACKBASE+0,x
sec
sbc #$02
sta STACKBASE+0,x
bcs :+
dec STACKBASE+2,x
: NEXT
eword
; H: ( x -- x' ) invert the bits in x
dword INVERT,"INVERT"
jsr _1parm
jsr _invert
NEXT
eword
; H: ( x -- x' ) invert the bits in x
dword NOT,"NOT"
bra INVERT::code
eword
; H: ( n -- n' ) negate n
dword NEGATE,"NEGATE"
jsr _1parm
jsr _negate
NEXT
eword
; H: ( n f -- n|n' ) if f < 0, then negate n
; non-standard
hword QNEGATE,"?NEGATE"
jsr _popay
and #$8000
bne NEGATE::code
NEXT
eword
; H: ( n -- n' ) take the absolute value of n
; we don't check parms on stack here because
; NEGATE will error if empty
dword ABS,"ABS"
lda STACKBASE+2,x
bpl :+
jsr _negate
: NEXT
eword
; H: ( d -- d' ) negate d
dword DNEGATE,"DNEGATE"
jsr _2parm
jsr _dnegate
NEXT ; push high cell
eword
; H: ( d -- d' ) take the absolute value of d
dword DABS,"DABS"
lda STACKBASE+2,x
bpl :+
jsr _dnegate
: NEXT
eword
; H: ( n1 n2 -- n3 ) n3 = n1+n2
dword PLUS,"+"
jsr _2parm
lda STACKBASE+4,x
clc
adc STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+6,x
adc STACKBASE+2,x
sta STACKBASE+6,x
stkinc: inx
inx
inx
inx
NEXT
eword
; H: ( n1 n2 -- n3 ) n3 = n1-n2
dword MINUS,"-"
jsr _2parm
lda STACKBASE+4,x
sec
sbc STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+6,x
sbc STACKBASE+2,x
sta STACKBASE+6,x
bra PLUS::stkinc
eword
; H: ( n1 n2 -- n3 ) n3 = n1 & n2
dword LAND,"AND"
jsr _2parm
lda STACKBASE+4,x
and STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+6,x
and STACKBASE+2,x
sta STACKBASE+6,x
bra PLUS::stkinc
eword
; H: ( n1 n2 -- n3 ) n3 = n1 | n2
dword LOR,"OR"
jsr _2parm
lda STACKBASE+4,x
ora STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+6,x
ora STACKBASE+2,x
sta STACKBASE+6,x
bra PLUS::stkinc
eword
; H: ( n1 n2 -- n3 ) n3 = n1 ^ n2
dword LXOR,"XOR"
jsr _2parm
lda STACKBASE+4,x
eor STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+6,x
eor STACKBASE+2,x
sta STACKBASE+6,x
bra PLUS::stkinc
eword
; H: ( n1 n2 -- n3 ) n3 = n1 << n2
dword LSHIFT,"LSHIFT"
jsr _2parm
jsr _popxr
ldy #.loword(shift-1)
lda #.hiword(shift-1)
jsr _iter_ay
NEXT
shift: asl STACKBASE+0,x
rol STACKBASE+2,x
clc
rtl
eword
; H: ( n1 n2 -- n3 ) n3 = n1 >> n2
dword RSHIFT,"RSHIFT"
jsr _2parm
jsr _popxr
ldy #.loword(shift-1)
lda #.hiword(shift-1)
jsr _iter_ay
NEXT
shift: lsr STACKBASE+2,x
ror STACKBASE+0,x
clc
rtl
eword
; H: ( n1 n2 -- n3 ) n3 = n1 << n2
dword LSHIFTX,"<<"
bra LSHIFT::code
eword
; H: ( n1 n2 -- n3 ) n3 = n1 >> n2
dword RSHIFTX,">>"
bra RSHIFT::code
eword
; H: ( n1 n2 -- n3 ) n3 = n1 >> n2, extending sign bit
dword ARSHIFT,">>A"
jsr _2parm
jsr _popxr
ldy #.loword(shift-1)
lda #.hiword(shift-1)
jsr _iter_ay
NEXT
Fix issue with 2/ and >>a uncovered by unit tests
2019-12-29 21:43:19 +00:00
shift: lda STACKBASE+2,x
cmp #$8000
initial full commit
2019-07-01 17:33:44 +00:00
ror STACKBASE+2,x
ror STACKBASE+0,x
clc
rtl
eword
; H: ( n -- n' ) shift n1 one bit left
dword TWOMULT,"2*"
jsr _1parm
jsl LSHIFT::shift
NEXT
eword
; H: ( n -- n' ) shift n1 one bit right
dword UTWODIV,"U2/"
jsr _1parm
jsl RSHIFT::shift
NEXT
eword
; H: ( n -- n' ) shift n1 one bit right, extending sign bit
dword TWODIV,"2/"
jsr _1parm
jsl ARSHIFT::shift
NEXT
eword
; H: ( n c-addr -- ) add n to value at c-addr
dword PSTORE,"+!"
ENTER
.dword DUP
.dword FETCH
.dword ROT
.dword PLUS
.dword SWAP
.dword STORE
EXIT
eword
; H: ( d -- n ) convert double-number to number
dword DtoS,"D>S"
jmp DROP::code
eword
; H: ( n -- d ) convert number to double-number
dword StoD,"S>D"
jsr _1parm
lda STACKBASE+2,x
and #$8000
bpl :+
lda #$FFFF
: tay
PUSHNEXT
eword
; H: ( n n -- d d ) convert two numbers to double-numbers
dword TWOStoD,"2S>D"
ENTER
.dword PtoR
.dword StoD
.dword RtoP
.dword StoD
EXIT
eword
; Factored for number conversion
.proc _dplus
lda STACKBASE+12,x
clc
adc STACKBASE+4,x
sta STACKBASE+12,x
lda STACKBASE+14,x
adc STACKBASE+6,x
sta STACKBASE+14,x
lda STACKBASE+8,x
adc STACKBASE+0,x
sta STACKBASE+8,x
lda STACKBASE+10,x
adc STACKBASE+2,x
sta STACKBASE+10,x
stkinc: txa
clc
adc #$08
tax
rts
.endproc
; H: ( d1 d2 -- d3 ) d3 = d1+d2
dword DPLUS,"D+"
jsr _4parm
jsr _dplus
NEXT
eword
; H: ( d1 d2 -- d3 ) d3 = d1-d2
dword DMINUS,"D-"
jsr _4parm
lda STACKBASE+12,x
sec
sbc STACKBASE+4,x
sta STACKBASE+12,x
lda STACKBASE+14,x
sbc STACKBASE+6,x
sta STACKBASE+14,x
lda STACKBASE+8,x
sbc STACKBASE+0,x
sta STACKBASE+8,x
lda STACKBASE+10,x
sbc STACKBASE+2,x
sta STACKBASE+10,x
jsr _dplus::stkinc
NEXT
eword
; System variables for temporary string buffers
hword dSBUF0,"$SBUF0"
SYSVAR SV_SBUF0
eword
hword dSBUF1,"$SBUF1"
SYSVAR SV_SBUF1
eword
hword dCSBUF,"$CSBUF"
SYSVAR SV_CSBUF
eword
; ( c-addr1 u1 -- c-addr2 u1 )
; Allocate a temporary string buffer for interpretation semantics of strings
; and return the address and length of the buffer
; if taking the slot used by an existing buffer, free it.
dword dTMPSTR,"$TMPSTR"
jsr _2parm
lda STACKBASE+0,x ; get u1
sta XR
lda STACKBASE+2,x
bne nomem ; only going to support ~64K strings for this
sta XR+2
jsr _alloc ; allocate memory for it
bcc nomem
pha ; save pointer
phy
ldy #SV_CSBUF ; get current string buffer
lda [SYSVARS],y
inc a
and #$01 ; only need low bit
sta [SYSVARS],y
pha ; save it
bne getbuf1
ldy #SV_SBUF0+2 ; select buf 0
bra getbuf
getbuf1: ldy #SV_SBUF1+2 ; select buf 1
getbuf: lda [SYSVARS],y ; get buffer pointer
sta WR+2 ; into WR
dey
dey
lda [SYSVARS],y
sta WR
ora WR+2
beq :+ ; no prior allocation if zero
jsr _free ; otherwise, free current memory
: lda STACKBASE+0,x ; length to XR
sta XR
lda STACKBASE+2,x
sta XR+2
lda STACKBASE+4,x ; original address to WR
sta WR
lda STACKBASE+6,x
sta WR+2
pla
bne setbuf1
ldy #SV_SBUF0 ; select buf 0
bra setbuf
setbuf1: ldy #SV_SBUF1 ; select buf 1
setbuf: pla ; update pointers
sta YR ; in YR
resolve #6; general clean-up
2020-01-05 00:25:41 +00:00
sta [SYSVARS],y ; in the appropriate system var
initial full commit
2019-07-01 17:33:44 +00:00
sta STACKBASE+4,x ; in the parameter stack
iny
iny
pla
sta YR+2
sta [SYSVARS],y
sta STACKBASE+6,x
resolve #6; general clean-up
2020-01-05 00:25:41 +00:00
sec ; move down is faster
jsr _memmove
initial full commit
2019-07-01 17:33:44 +00:00
NEXT
nomem: ldy #.loword(-18)
lda #.hiword(-18)
jmp _throway
eword
; H: ( -- ' ' )
dword BL,"BL"
lda #' '
jsr _pusha
NEXT
eword
; H: ( -- ) emit a space
dword SPACE,"SPACE"
ENTER
.dword BL
.dword EMIT
EXIT
eword
; H: ( u -- ) emit u spaces
dword SPACES,"SPACES"
jsr _popxr
ldy #.loword(do_emit-1)
lda #.hiword(do_emit-1)
jsr _iter_ay
NEXT
do_emit: ENTER
.dword BL
.dword EMIT
CODE
clc
rtl
eword
; H: ( -- <cr> )
dword CARRET,"CARRET"
lda #c_cr
jsr _pusha
NEXT
eword
; H: ( -- <lf> )
dword LINEFEED,"LINEFEED"
lda #c_lf
jsr _pusha
NEXT
eword
; H: ( -- ) emit a CR with no linefeed, set #OUT to 0
dword pCR,"(CR"
ENTER
.dword CARRET
.dword EMIT
ONLIT 0
.dword NOUT
.dword STORE
EXIT
eword
; H: ( -- ) emit a LF
hword LF,"LF"
ENTER
.dword LINEFEED
.dword EMIT
EXIT
eword
; H: ( -- ) emit a CR/LF combination, set increment #LINE
dword CR,"CR"
ENTER
ONLIT 1
.dword NLINE
.dword PSTORE
.dword pCR
.dword LF
EXIT
eword
; H: ( -- <bel> )
dword BELL,"BELL"
lda #c_bell
jsr _pusha
NEXT
eword
; H: ( -- <bs> )
dword BS,"BS"
lda #c_bs
jsr _pusha
NEXT
eword
; H: ( -- ) clear screen & home cursor (uses ANSI escape sequence)
dword PAGE,"PAGE"
ENTER
.dword _SLIT
.dword 7
.byte $1B,"[2J",$1B,"[H"
.dword TYPE
EXIT
eword
; H: ( u1 u2 -- ) place cursor at col u1 row u2 (uses ANSI escape sequence)
dword AT_XY,"AT-XY"
ENTER
ONLIT $1B
.dword EMIT
ONLIT '['
.dword EMIT
.dword INCR
ONLIT UDOTZ
ONLIT 10
.dword TMPBASE
ONLIT ';'
.dword EMIT
.dword INCR
ONLIT UDOTZ
ONLIT 10
.dword TMPBASE
ONLIT 'H'
.dword EMIT
EXIT
eword
; H: ( ud u1 -- u2 u3 ) divide ud by u1, giving quotient u3 and remainder u2
dword UMDIVMOD,"UM/MOD"
jsr _3parm
lda STACKBASE+0,x
ora STACKBASE+2,x
beq _divzero
jsr _umdivmod
bcs _overflow
NEXT
eword
; H: ( d n1 -- n2 n3 ) symmetric divide d by n1, giving quotient n3 and remainder n2
dword SMDIVREM,"SM/REM"
.if 1 ; native version
jsr _3parm
lda STACKBASE+0,x
ora STACKBASE+2,x
beq _divzero
jsr _smdivrem
bcs _overflow
NEXT
.else ; secondary version
ENTER
.dword TWODUP
.dword LXOR ; compute result sign
.dword PtoR ; and save
.dword OVER ; copy dividend sign
.dword PtoR ; and save
.dword ABS ; take absolute value of args
.dword PtoR
.dword DABS
.dword RtoP
.dword UMDIVMOD ; perform unsigned division
.dword SWAP ; move quotient out of the way
.dword RtoP ; get dividend sign
.dword QNEGATE ; and negate the remainder if it should be negative
.dword SWAP ; put the quotient back
.dword RtoP ; get result sign
.dword QNEGATE ; and make negative if it should be negative
EXIT
.endif
eword
; helpers to throw division errors
.proc _divzero
ldy #.loword(-10)
lda #.hiword(-10)
jmp _throway
.endproc
.proc _overflow
ldy #.loword(-11)
lda #.hiword(-11)
jmp _throway
.endproc
; H: ( n -- s ) s = -1 if n is negative, 0 if 0, 1 if positive
dword SIGNUM,"SIGNUM"
jsr _1parm
jsr _signum
NEXT
eword
; H: ( d n1 -- n2 n3 ) floored divide d by n1, giving quotient n3 and remainder n2
dword FMDIVMOD,"FM/MOD"
temporarily switch to secondary FM/MOD, ref #5
2020-01-05 01:38:25 +00:00
.if 0 ; primitive, using math lib FM/MOD code based on SM/REM
initial full commit
2019-07-01 17:33:44 +00:00
jsr _3parm
lda STACKBASE+0,x
ora STACKBASE+2,x
beq _divzero
jsr _fmdivmod
bcs _overflow
NEXT
.else ; secondary, using SM/REM
ENTER
.dword DUP
.dword PtoR
.dword SMDIVREM
.dword OVER
.dword SIGNUM
.dword RCOPY
.dword SIGNUM
.dword NEGATE
.dword EQUAL
.dword _IF
.dword else
.dword DECR
.dword SWAP
.dword RtoP
.dword PLUS
.dword SWAP
EXIT
else: .dword RDROP
EXIT
.endif
eword
; H: ( u1 u2 -- u3 u4 ) divide u1 by u2, giving quotient u4 and remainder u3
dword UDIVMOD,"U/MOD"
ENTER
.dword PtoR
.dword StoD
.dword RtoP
.dword UMDIVMOD
EXIT
eword
; H: ( n1 n2 -- n3 n4 ) symmetric divide n1 by n2, giving quotient n4 and remainder n3
dword DIVMOD,"/MOD"
ENTER
.dword PtoR
.dword StoD
.dword RtoP
.dword FMDIVMOD
EXIT
eword
; H: ( n1 n2 -- n3 ) symmetric divide n1 by n2, giving remainder n3
dword MOD,"MOD"
ENTER
.dword DIVMOD
.dword DROP
EXIT
eword
; H: ( n1 n2 -- n3 ) symmetric divide n1 by n2, giving quotient n3
dword DIV,"/"
ENTER
.dword DIVMOD
.dword NIP
EXIT
eword
; H: ( n1 n2 n3 -- n4 n5 ) n4, n5 = symmetric rem, quot of n1*n2/n3
dword MULTDIVMOD,"*/MOD"
ENTER
.dword PtoR
.dword MMULT
.dword RtoP
.dword FMDIVMOD
EXIT
eword
; H: ( n1 n2 n3 -- n4 ) n4 = symmetric quot of n1*n2/n3
dword MULTDIV,"*/"
ENTER
.dword MULTDIVMOD
.dword NIP
EXIT
eword
; H: ( d1 n1 -- d2 n2 ) d2, n2 = remainder and quotient of d1/n1
; unsigned 64-bit by 32-bit divide, leaving 64-bit quotient and 32-bit remainder
; used by double-number pictured numeric output routines only
dword UDDIVMOD,"UD/MOD"
ENTER
.dword PtoR
.dword ZERO
.dword RCOPY
.dword UMDIVMOD
.dword RtoP
.dword SWAP
.dword PtoR
.dword UMDIVMOD
.dword RtoP
EXIT
eword
; H: ( u1 u2 -- ud ) ud = u1*u2
dword UMMULT,"UM*"
jsr _2parm
jsr _umult
NEXT
eword
; H: ( u1 u2 -- u3 ) u3 = u1*u2
dword UMULT,"U*"
ENTER
.dword UMMULT
.dword DtoS
EXIT
eword
; H: ( n1 n2 -- d ) d = n1*n2
dword MMULT,"M*"
jsr _2parm
lda STACKBASE+2,x ; calculate sign flag
eor STACKBASE+6,x
pha ; save it for later
jsr _2abs
jsr _umult
pla
bpl :+
jsr _dnegate
: NEXT
eword
; H: ( n1 n2 -- n3 ) n3 = n1*n2
dword MULT,"*"
ENTER
.dword MMULT
.dword DtoS
EXIT
eword
; H: ( u1 -- u2 u3 ) u2 = closest square root <= to the true root, u3 = remainder
dword SQRTREM,"SQRTREM"
jsr _sqroot
NEXT
eword
; H: ( n1 -- n2 ) if n1 is odd, n2=n1+1, otherwise n2=n1
dword EVEN,"EVEN"
jsr _1parm
lda STACKBASE+0,x
and #1
beq :+
jmp INCR::code
: NEXT
eword
; ( -- a-addr ) return address of WORD buffer
hword WORDBUF,"WORDBUF"
ENTER
.dword HERE
ONLIT 16
.dword PLUS
EXIT
eword
.if pad_size > 0
; H: ( -- a-addr ) return address of PAD
dword PAD,"PAD"
ENTER
.dword WORDBUF
ONLIT word_buf_size
.dword PLUS
EXIT
eword
.endif
; ( -- a-addr ) variable containing pictured numeric output pointer
hword dPPTR,"$PPTR"
SYSVAR SV_dPPTR
eword
; H: ( -- ) begin pictured numeric output
dword PBEGIN,"<#"
ENTER
.dword WORDBUF
ONLIT word_buf_size
.dword PLUS
.dword dPPTR
.dword STORE
EXIT
eword
; H: ( c -- ) place c in pictured numeric output
dword PHOLD,"HOLD"
ENTER
.dword dPPTR
.dword FETCH
.dword DECR
.dword DUP
.dword dPPTR
.dword STORE
.dword CSTORE
EXIT
eword
; H: ( n -- ) place - in pictured numeric output if n is negative
dword PSIGN,"SIGN"
jsr _popay
and #$8000
beq :+
lda #'-'
jsr _pusha
jmp PHOLD::code
: NEXT
eword
; H: ( ud1 -- ud2 ) divide ud1 by BASE, convert remainder to char and HOLD it, ud2 = quotient
dword PNUM,"#"
ENTER
.dword BASE
.dword FETCH
.dword UDDIVMOD
.dword ROT
CODE
hold: jsr _popay
tya
jsr _d_to_c
jsr _pusha
jmp PHOLD::code
eword
; H: ( u1 -- u2 ) divide u1 by BASE, convert remainder to char and HOLD it, u2 = quotient
dword PUNUM,"U#"
ENTER
.dword ZERO
.dword BASE
.dword FETCH
.dword UMDIVMOD
.dword SWAP
CODE
bra PNUM::hold
eword
; H: ( ud -- 0 ) perform # until quotient is zero
dword PNUMS,"#S"
ENTER
another: .dword PNUM
.dword TWODUP
.dword LOR
.dword _IFFALSE
.dword another
EXIT
eword
; H: ( u -- 0 ) perform U# until quotient is zero
dword PUNUMS,"U#S"
ENTER
another: .dword PUNUM
.dword DUP
.dword _IFFALSE
.dword another
EXIT
eword
; H: ( ud -- ) conclude pictured numeric output
dword PDONE,"#>"
ENTER
.dword TWODROP
getstr: .dword dPPTR
.dword FETCH
.dword WORDBUF
ONLIT word_buf_size
.dword PLUS
.dword dPPTR
.dword FETCH
.dword MINUS
EXIT
eword
; H: ( u -- ) conclude pictured numeric output
dword PUDONE,"U#>"
ENTER
.dword DROP
JUMP PDONE::getstr
eword
; ( d f -- c-addr u), f = true if signed number
hword dUDFMT,"$UDFMT"
ENTER
.dword _IF
.dword ns
.dword DUP
.dword PtoR
.dword DABS
JUMP doit
ns: .dword ZERO
.dword PtoR
doit: .dword PBEGIN
.dword PNUMS
.dword RtoP
.dword PSIGN
.dword PDONE
EXIT
eword
; ( n f -- c-addr u), f = true if signed number
hword dUFMT,"$UFMT"
.if 1 ; slightly smaller & slower
ENTER
.dword _IF
.dword ns
.dword DUP
.dword PtoR
.dword ABS
JUMP :+
ns: .dword ZERO
.dword PtoR
: .dword ZERO ; we already saved the sign, no need to sign-extend
JUMP dUDFMT::doit
.else ; bigger & faster
ENTER
.dword _IF
.dword ns
.dword DUP
.dword PtoR
.dword ABS
JUMP doit
ns: .dword ZERO
.dword PtoR
doit: .dword PBEGIN
.dword PUNUMS
.dword RtoP
.dword PSIGN
.dword PUDONE
EXIT
.endif
eword
; H: ( n -- c-addr u ) convert n to text via pictured numeric output
dword NTOTXT,"(.)"
ENTER
.dword TRUE
.dword dUFMT
EXIT
eword
; H: ( u -- c-addr u ) convert u to text via pictured numeric output
dword UTOTXT,"(U.)"
ENTER
.dword FALSE
.dword dUFMT
EXIT
eword
; H: ( c-addr u1 u2 ) output c-addr u1 in a field of size u2
hword DFIELD,"$FIELD"
ENTER
.dword OVER ; ( c-addr u1 u2 -- c-addr u1 u2 u1' )
.dword MINUS ; ( c-addr u1 u2 u1' -- c-addr u1 u3 ) u3=remaining field
.dword DUP ; ( c-addr u1 u3 -- c-addr u1 u3 u3'
.dword ZEROLT ; ( c-addr u1 u3 u3' -- c-addr u1 u3 f )
.dword _IF ; ( c-addr u1 u3 f -- c-addr u1 u3 )
.dword :+ ; 0 or more in field, go print some spaces
.dword DROP
.dword TYPE
EXIT
: .dword SPACES
.dword TYPE
EXIT
eword
; H: ( d u -- ) output d in a field of u chars
dword DDOTR,"D.R"
ENTER
.dword PtoR
.dword TRUE
.dword dUDFMT
.dword RtoP
.dword DFIELD
EXIT
eword
; H: ( d -- ) output d
dword DDOT,"D."
ENTER
.dword TRUE
.dword dUDFMT
.dword TYPE
.dword SPACE
EXIT
eword
; H: ( u1 u2 -- ) output u1 in a field of u2 chars
dword UDOTR,"U.R"
ENTER
.dword PtoR
.dword FALSE
.dword dUFMT
.dword RtoP
.dword DFIELD
EXIT
eword
; ( u1 -- ) output u1 with no trailing space
dword UDOTZ,"U.0"
ENTER
.dword ZERO
.dword UDOTR
EXIT
eword
; H: ( n u -- ) output n in a field of u chars
dword DOTR,".R"
ENTER
.dword PtoR
.dword TRUE
.dword dUFMT
.dword RtoP
.dword DFIELD
EXIT
eword
; H: ( u -- ) output u
dword UDOT,"U."
ENTER
.dword FALSE
.dword dUFMT
.dword TYPE
.dword SPACE
EXIT
eword
; H: ( n -- ) output n
dword DOT,"."
ENTER
.dword TRUE
.dword dUFMT
.dword TYPE
.dword SPACE
EXIT
eword
; H: ( n -- ) output n
dword SDOT,"S."
bra DOT::code
eword
; H: ( a-addr -- ) output signed contents of cell at a-addr
dword SHOW,"?"
ENTER
.dword FETCH
.dword DOT
EXIT
eword
; H: ( n -- ) output n in decimal base
dword DOTD,".D"
ENTER
ONLIT 10
tmpbase: ONLIT DOT
.dword SWAP
.dword TMPBASE
EXIT
eword
; H: ( n -- ) output n in hexadecimal base
dword DOTH,".H"
ENTER
ONLIT 16
JUMP DOTD::tmpbase
eword
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
.proc _popxryrwr
initial full commit
2019-07-01 17:33:44 +00:00
jsr _popxr
jsr _popyr
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
jmp _popwr
.endproc
; H: ( addr1 addr2 len -- ) move memory
dword MOVE,"MOVE"
jsr _popxryrwr
resolve #6; general clean-up
2020-01-05 00:25:41 +00:00
jsr _memmove
initial full commit
2019-07-01 17:33:44 +00:00
NEXT
eword
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
; H: ( addr1 addr2 len -- ) move startomg from the bottom
initial full commit
2019-07-01 17:33:44 +00:00
dword CMOVE,"CMOVE"
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
jsr _popxryrwr
clc
jsr _memmove_c
NEXT
initial full commit
2019-07-01 17:33:44 +00:00
eword
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
; H: ( addr1 addr2 len -- ) move starting from the top
initial full commit
2019-07-01 17:33:44 +00:00
dword CMOVEUP,"CMOVE>"
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
jsr _popxryrwr
sec
resolve #6; general clean-up
2020-01-05 00:25:41 +00:00
jsr _memmove_c
initial full commit
2019-07-01 17:33:44 +00:00
NEXT
eword
; H: ( addr1 addr2 u1 -- n1 ) compare two strings of length u1
; IEEE 1275
dword COMP,"COMP"
stz ZR ; case sensitive
make sure CMOVE and CMOVE> are according to spec
2020-01-05 23:39:37 +00:00
docomp: jsr _popxryrwr
initial full commit
2019-07-01 17:33:44 +00:00
sep #SHORT_A
.a8
ldy #$0000
lp: cpy XR
bcs equal
bit ZR
bmi insens
lda [WR],y ; case sensitive compare
cmp [YR],y
postcmp: bne neq
iny
bra lp
insens: lda [WR],y ; case insensitive compare
jsr _cupper8
sta ZR+2 ; use ZR+2 to hold converted byte
lda [YR],y
jsr _cupper8
cmp ZR+2
bra postcmp
neq: rep #SHORT_A
.a16
bcc less
lda #$0000
tay
iny
PUSHNEXT
less: lda #$FFFF
tay
PUSHNEXT
equal: rep #SHORT_A
.a16
lda #$0000
tay
PUSHNEXT
eword
; H: ( addr1 addr2 u1 -- n1 ) case-insensitive compare two strings of length u1
; non-standard
dword CICOMP,"CICOMP"
stz ZR
dec ZR
bra COMP::docomp
eword
; H: ( addr1 u1 addr2 u2 -- n1 ) compare two strings
; ANS Forth
dword COMPARE,"COMPARE"
ENTER
.dword ROT ; ( addr1 u1 addr2 u2 -- addr1 addr2 u2 u1 )
.dword TWODUP
.dword TWOPtoR ; ( R: -- u2' u1' )
.dword MIN
.dword COMP
.dword DUP
.dword _IF
.dword equal
.dword RDROP
.dword RDROP
EXIT
equal: .dword DROP
.dword TWORtoP
.dword SWAP
.dword MINUS
.dword SIGNUM
EXIT
eword
; H: ( c-addr1 u1 n -- c-addr2 u2 ) adjust string
dword sSTRING,"/STRING"
.if 1 ; secondary - shorter, slower
ENTER
.dword TUCK
.dword MINUS
.dword PtoR
.dword PLUS
.dword RtoP
EXIT
.else ; primitive - longer, faster
jsr _3parm
lda STACKBASE+8,x
clc
adc STACKBASE+0,x
sta STACKBASE+8,x
lda STACKBASE+10,x
adc STACKBASE+2,x
sta STACKBASE+10,x
lda STACKBASE+4,x
sec
sbc STACKBASE+0,x
sta STACKBASE+4,x
lda STACKBASE+6,x
sbc STACKBASE+2,x
sta STACKBASE+6,x
jsr _stackincr
NEXT
.endif
eword
; H: ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 flag )
; WR XR YR ZR
; in practice ZR can only be 16-bit like most other string stuff
dword SEARCH,"SEARCH"
jsr _4parm
jsr _popay
sty ZR
sta ZR+2
jsr _popyr
lda STACKBASE+0,x ; now we are down to ( c-addr1 u1 ) on stack
sta XR ; get them and put them into WR and XR
lda STACKBASE+2,x
sta XR+2
lda STACKBASE+4,x
sta WR
lda STACKBASE+6,x
sta WR+2
bra chklen
next: rep #SHORT_A
.a16
jsr _incwr
jsr _decxr
chklen: lda XR+2
cmp ZR+2
bne :+
lda XR
cmp ZR
: bcc nomatch ; XR < ZR, no match found!
ldy ZR ; let's see if there's a match
beq nomatch ; nope out of u2 is zero
sep #SHORT_A
.a8
lp: dey ; it needs to be one less than
lda [WR],y
cmp [YR],y
bne next
cpy #$0000
bne lp ; keep matching
rep #SHORT_A
.a16
lda WR+2 ; match found, return results!
sta STACKBASE+6,x
lda WR
sta STACKBASE+4,x
lda XR+2
sta STACKBASE+2,x
lda XR
sta STACKBASE+0,x
lda #$FFFF
bra :+
nomatch: lda #$0000
: tay
PUSHNEXT
eword
; H: ( addr len char -- ) fill memory with char
dword FILL,"FILL"
ENTER
.dword NROT
CODE
ldy #.loword(dofill-1)
lda #.hiword(dofill-1)
jsr _str_op_ays
jsr _stackincr
NEXT
dofill: sep #SHORT_A
.a8
lda STACKBASE+0,x
sta [WR]
rep #SHORT_A
.a16
clc
rtl
eword
; H: ( addr len -- ) fill memory with spaces
dword BLANK,"BLANK"
ENTER
ONLIT ' '
.dword FILL
EXIT
eword
; H: ( addr len -- ) zero fill memory with spaces
dword ERASE,"ERASE"
ENTER
.dword ZERO
.dword FILL
EXIT
eword
; H: ( addr len -- ) perform WBFLIP on the words in memory
dword WBFLIPS,"WBFLIPS"
ldy #.loword(doflip-1)
lda #.hiword(doflip-1)
jsr _str_op_ays
NEXT
doflip: lda [WR]
xba
sta [WR]
jsr _incwr
clc
rtl
eword
; H: ( addr len -- ) perform LBFLIP on the cells in memory
dword LBFLIPS,"LBFLIPS"
ldy #.loword(doflip-1)
lda #.hiword(doflip-1)
jsr _str_op_ays
NEXT
doflip: ldy #$02
lda [WR]
xba
pha
lda [WR],y
xba
cont: sta [WR]
pla
sta [WR],y
lda WR
clc
adc #.loword(3)
sta WR
lda WR+2
adc #.hiword(3)
sta WR+2
clc
rtl
eword
; H: ( addr len -- ) perform LWFLIP on the cells in memory
dword LWFLIPS,"LWFLIPS"
ldy #.loword(doflip-1)
lda #.hiword(doflip-1)
jsr _str_op_ays
NEXT
doflip: ldy #$02
lda [WR]
pha
lda [WR],y
bra LBFLIPS::cont
eword
.if include_fcode
; FCode support words
; H: ( addr -- char true ) access memory at addr, returning char
dword CPEEK,"CPEEK"
ENTER
.dword CFETCH
.dword TRUE
EXIT
eword
; H: ( addr -- word true ) access memory at addr, returning word
dword WPEEK,"WPEEK"
ENTER
.dword WFETCH
.dword TRUE
EXIT
eword
; H: ( addr -- cell true ) access memory at addr, returning cell
dword LPEEK,"LPEEK"
ENTER
.dword LFETCH
.dword TRUE
EXIT
eword
; H: ( char addr -- true ) store char at addr
dword CPOKE,"CPOKE"
ENTER
.dword CSTORE
.dword TRUE
EXIT
eword
; H: ( word addr -- true ) store word at addr
dword WPOKE,"WPOKE"
ENTER
.dword WSTORE
.dword TRUE
EXIT
eword
; H: ( cell addr -- true ) store cell at addr
dword LPOKE,"LPOKE"
ENTER
.dword LSTORE
.dword TRUE
EXIT
eword
; FCode evaluator variables:
; Variable containing FCode instruction pointer
hword dFCODE_IP,"$FCODE-IP"
SYSVAR SV_FCODE_IP
eword
; If set nonzero, FCode interpretation will end and the value thrown
hword dFCODE_END,"$FCODE-END"
SYSVAR SV_FCODE_END
eword
; Bytes to increment $FCODE-IP for an FCode fetch. Nearly always 1.
hword dFCODE_SPREAD,"$FCODE-SPREAD"
SYSVAR SV_FCODE_SPREAD
eword
; If zero, the FCode offset size is 8 bits, otherwise 16.
hword dFCODE_OFFSET,"$FCODE-OFFSET"
SYSVAR SV_FCODE_OFFSET
eword
; Contains the XT of the FCode fetch instruction, usually RB@
hword dFCODE_FETCH,"$FCODE-FETCH"
SYSVAR SV_FCODE_FETCH
eword
; Contains the address of the FCode Master Table
hword dFCODE_TABLES,"$FCODE-TABLES"
SYSVAR SV_FCODE_TABLES
eword
; Contains the address of the last defined FCode function
hword dFCODE_LAST,"$FCODE-LAST"
SYSVAR SV_FCODE_LAST
eword
; If one, place headers on header-optional Fcode functions
; set by $BYTE-EXEC to the result of FCODE-DEBUG? if it exists
hword dFCODE_DEBUG,"$FCODE-DEBUG"
SYSVAR SV_FCODE_DEBUG
eword
; H: ( -- u ) Return FCode revision
dword xFCODE_REVISION,"FCODE-REVISION"
ENTER
ONLIT $87
.dword DO_TOKEN
EXIT
eword
; H: ( -- ) display FCode IP and byte, throw exception -256
dword FERROR,"FERROR"
ENTER
.dword dFCODE_IP
.dword FETCH
.dword DUP
.dword UDOT
.dword CFETCH
.dword UDOT
ONLIT -256
.dword THROW
EXIT
eword
; H: ( xt fcode# f -- ) set fcode# to execute xt, immediacy f
dword SET_TOKEN,"SET-TOKEN"
jml xSET_TOKEN_code
eword
; H: ( fcode# -- xt f ) get fcode#'s xt and immediacy
dword GET_TOKEN,"GET-TOKEN"
jsr _1parm
jsl lGET_TOKEN
NEXT
eword
; FCode atomic memory accessors, IEEE 1275-1994 says these may be overwritten by FCode
; to do device-specific accesses.
; ( addr -- char ) fetch char at addr, atomically
hword dRBFETCH,"$RB@"
jmp CFETCH::code
eword
; ( addr -- word ) fetch word at addr
; Note that IEEE 1275-1994 requires the fetch to occur in a single access, but the '816
; has an 8-bit bus so this is technically impossible.
hword dRWFETCH,"$RW@"
jmp WFETCH::code
eword
; ( addr -- cell ) fetch cell at addr
; Note that IEEE 1275-1994 requires the fetch to occur in a single access, but the '816
; has an 8-bit bus so this is technically impossible.
hword dRLFETCH,"$RL@"
jmp LFETCH::code
eword
; ( byte addr -- ) store byte at addr, atomically
hword dRBSTORE,"$RB!"
jmp CSTORE::code
eword
; ( word addr -- ) store word at addr
; Note that IEEE 1275-1994 requires the store to occur in a single access, but the '816
; has an 8-bit bus so this is technically impossible.
hword dRWSTORE,"$RW!"
jmp WSTORE::code
eword
; ( cell addr -- ) store cell at addr
; Note that IEEE 1275-1994 requires the store to occur in a single access, but the '816
; has an 8-bit bus so this is technically impossible.
hword dRLSTORE,"$RL!"
jmp LSTORE::code
eword
; H: ( addr -- byte ) perform FCode-equivalent RB@: fetch byte
dword RBFETCH,"RB@",F_IMMED
ENTER
ONLIT $230
.dword DO_TOKEN
EXIT
eword
; H: ( addr -- word ) perform FCode-equivalent RW@: fetch word
dword RWFETCH,"RW@",F_IMMED
ENTER
ONLIT $232
.dword DO_TOKEN
EXIT
eword
; H: ( addr -- cell ) perform FCode-equivalent RL@: fetch cell
dword RLFETCH,"RL@",F_IMMED
ENTER
ONLIT $234
.dword DO_TOKEN
EXIT
eword
; H: ( byte addr -- ) perform FCode-equivalent RB!: store byte
dword RBSTORE,"RB!",F_IMMED
ENTER
ONLIT $231
.dword DO_TOKEN
EXIT
eword
; H: ( word addr -- ) perform FCode-equivalent RW!: store word
dword RWSTORE,"RW!",F_IMMED
ENTER
ONLIT $233
.dword DO_TOKEN
EXIT
eword
; H: ( cell addr -- ) perform FCode-equivalent RL!, store cell
dword RLSTORE,"RL!",F_IMMED
ENTER
ONLIT $235
.dword DO_TOKEN
EXIT
eword
.if 0 ; stuff for testing
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword xSET_MUTABLE_FTABLES,"SET-MUTABLE-FTABLES" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword SET_MUTABLE_FTABLES
EXIT
eword
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword xSET_RAM_FTABLE,"SET-RAM-FTABLE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword SET_RAM_FTABLE
EXIT
eword
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword xSET_ROM_FTABLE,"SET-ROM-FTABLE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword SET_ROM_FTABLE
EXIT
eword
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword xGET_FTABLES,"GET-FTABLES" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword GET_FTABLES
EXIT
eword
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword xSAVE_FCODE_STATE,"SAVE-FCODE-STATE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword SAVE_FCODE_STATE
EXIT
eword
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword xRESTORE_FCODE_STATE,"RESTORE-FCODE-STATE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword RESTORE_FCODE_STATE
EXIT
eword
.endif
; FCode evaluation
; this does *not* save and restore the FCode evaluator state, that's what byte-load is
; for. This just gets things going, and unless SET-TOKEN is called, sticks with the ROM
; FCode tables.
; H: ( addr xt -- ) evaluate FCode at addr with fetch function xt, do not save state
dword dBYTE_EXEC,"$BYTE-EXEC"
jsr _2parm
ENTER
SLIT "FCODE-DEBUG?" ; see if user wants optional headers
.dword dFIND
.dword _IF
.dword nope
.dword EXECUTE
.dword dFCODE_DEBUG
.dword STORE
.dword _SKIP
nope: .dword TWODROP
.dword DUP
.dword ONE
.dword ULTE
.dword _IF
.dword usext
.dword DROP ; Drop supplied xt
ONLIT $230 ; RB@
.dword GET_TOKEN ; get XT
.dword DROP ; drop the flag
usext: .dword dFCODE_FETCH ; and put it in $FCODE-FETCH
.dword STORE
.dword DECR ; need to start with address -1
.dword dFCODE_IP
.dword STORE
.dword ONE
.dword dFCODE_SPREAD
.dword STORE
.dword dFCODE_END
.dword OFF
.dword dFCODE_OFFSET
.dword OFF
.dword xFCODE_EVALUATE
EXIT
eword
; H: ( addr xt -- ) sav state, evaluate FCode at addr with fetch function xt, restore state
dword BYTE_LOAD,"BYTE-LOAD"
ENTER
.dword SAVE_FCODE_STATE
.dword PtoR
ONLIT dBYTE_EXEC
.dword CATCH
;.dword DOTS
.dword RtoP
.dword RESTORE_FCODE_STATE
.dword THROW
EXIT
eword
.endif ; end of FCode stuff
; H: ( addr len -- ) dump memory
dword DUMP,"DUMP"
ENTER
.dword BOUNDS
JUMP addr
lp: .dword DUP
ONLIT $F
.dword LAND
.dword _IFFALSE
.dword noaddr
addr: .dword CR
.dword DUP
ONLIT 8
.dword UDOTR
ONLIT ':'
.dword EMIT
.dword SPACE
noaddr: .dword DUP
.dword CFETCH
ONLIT 2
.dword UDOTR
.dword SPACE
.dword INCR
.dword TWODUP
.dword ULTE
.dword _IF
.dword lp
.dword TWODROP
EXIT
eword
; H: ( xt -- addr|0 ) get link field of function at xt or 0 if none
dword rLINK,">LINK"
jsr _popyr
jsr _xttohead
bcc nolink
ldy YR
lda YR+2
PUSHNEXT
nolink: lda #$0000
tay
PUSHNEXT
eword
; H: ( xt -- c-addr u ) get string name of function at xt, or ^xt if anonymous/noname
dword rNAME,">NAME"
ENTER
.dword ZERO ; ( xt -- xt 0 )
.dword PtoR ; ( xt 0 -- xt ) ( R: -- 0 )
lp: .dword RCOPY ; ( xt u )
ONLIT NAMEMSK ; ( xt u -- xt u u1 )
.dword UGT ; ( xt u u1 -- xt f ) is name too long?
.dword _IFFALSE ; ( xt f -- xt )
.dword noname ; True branch, stack is ( xt 0 ) (R: u )
.dword DUP ; ( xt -- xt xt' )
.dword RCOPY ; ( xt xt' - xt xt' u )
.dword INCR ; ( xt xt' u -- xt xt' u' )
.dword MINUS ; ( xt xt' u' -- xt xt'' )
.dword CFETCH ; ( xt xt'' -- xt c )
.dword DUP ; ( xt c -- xt c c' )
ONLIT $80 ; ( xt c c' -- xt c c' $80 )
.dword LAND ; ( xt c c' -- xt c f )
.dword _IFFALSE ; ( xt c f -- xt c )
.dword done ; true branch
.dword DROP ; ( xt c -- xt )
.dword RINCR ; ( xt ) ( R: u -- u' )
JUMP lp
done: ONLIT NAMEMSK ; ( xt c -- xt c m )
.dword LAND ; ( xt c m -- xt l ) l = length
.dword RCOPY ; ( xt l -- xt l u ) ( R: u )
.dword EQUAL ; ( xt l u -- xt f )
.dword _IF ; ( xt f -- xt )
.dword noname ; false branch, stack is ( xt ) ( R: u )
.dword RCOPY ; ( xt -- xt u ) ( R: u )
.dword QDUP ; ( xt u -- xt u | xt u u )
.dword _IF ; ( xt u | xt u u -- xt | xt u )
.dword noname ; false branch, stack is ( xt ) ( R: u )
.dword MINUS ; ( xt u -- c-addr )
.dword RtoP ; ( c-addr -- c-addr u )
EXIT
noname: .dword RDROP ; ( xt ) ( R: u -- )
noname1: .dword PBEGIN
.dword PUNUMS ; ( xt -- )
ONLIT '^'
.dword PHOLD
.dword PUDONE ; ( -- c-addr u )
EXIT
eword
rNAME_noname1 = rNAME::noname1
; H: ( c-addr -- c-addr+1 u ) count packed string at c-addr
dword COUNT,"COUNT"
ENTER
.dword DUP
.dword INCR
.dword SWAP
.dword CFETCH
EXIT
eword
; H: ( str len addr -- addr ) pack string into addr, similar to PLACE in some Forths
dword PACK,"PACK"
jsr _3parm
jsr _popyr
jsr _popxr
jsr _popwr
lda XR+2
bne bad
lda XR
cmp #$100
bcs bad
sta [YR]
ldy YR
lda YR+2
jsr _pushay
inc YR
bne :+
inc YR+2
resolve #6; general clean-up
2020-01-05 00:25:41 +00:00
: sec ; move down is faster
jsr _memmove_c
initial full commit
2019-07-01 17:33:44 +00:00
NEXT
bad: ldy #.loword(-18)
lda #.hiword(-18)
jmp _throway
eword
; H: ( c-addr u1 -- c-addr u2 ) u2 = length of string with trailing spaces omitted
dword MTRAILING,"-TRAILING"
lda STACKBASE+4,x
sta WR
lda STACKBASE+6,x
sta WR+2
jsr _decwr
ldy STACKBASE+0,x
lp: lda [WR],y
and #$FF
cmp #' '
bne done
dey
bne lp
done: sty STACKBASE+0,x
NEXT
eword
; H: ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) convert text to number
; note: only converts positive numbers!
dword GNUMBER,">NUMBER"
jsr _4parm
ldy #SV_BASE+2
lda [SYSVARS],y
sta YR+2
dey
dey
lda [SYSVARS],y
sta YR
jsr _popxr ; u1 (length)
jsr _popwr ; c-addr1 ( stack is now just d )
digit: lda XR ; see if no more chars left
ora XR+2
beq done
lda [WR]
and #$FF ; enforce char
jsr _c_to_d ; convert to digit
bcc done ; if out of range, can't use it
cmp YR ; check against base
bcs done ; if >=, can't use it
.if 1
jsr _pusha ; ( -- ud1l ud1h n )
jsr _swap ; ( -- ud1l n ud1h )
ldy YR
lda #$0000
jsr _pushay ; ( -- ud1l n ud1h base )
jsr _umult ; ( -- ud1l n ud1h*basel 0 )
inx
inx
inx
inx ; ( -- ud1l n ud1h*basel )
jsr _rot ; ( -- n ud1h*basel ud1l )
ldy YR
lda #$0000
jsr _pushay ; ( -- n ud1h*basel ud1l base )
jsr _umult ; ( -- n ud1h*basel ud1l*basel ud1l*baseh )
jsr _dplus ; ( -- ud2 )
.else
pha ; save converted digit
lda YR
sta STACKBASE+0,x ; replace high cell of ud with base
stz STACKBASE+2,x ; base should never be > 65535!
jsr _umult ; multiply ud cells together
pla ; get digit back
clc
adc STACKBASE+4,x ; low order word of low order cell
sta STACKBASE+4,x
lda STACKBASE+6,x ; high order word of low order cell
adc #$00
sta STACKBASE+6,x
stz STACKBASE+0,x ; zero the high word
stz STACKBASE+2,x
.endif
jsr _decxr
jsr _incwr
bra digit
done: ldy WR
lda WR+2
jsr _pushay
ldy XR
lda XR+2
PUSHNEXT
eword
; H: ( str len char -- r-str r-len l-str l-len ) parse string for char, returning
; H: the left and right sides
dword LEFT_PARSE_STRING,"LEFT-PARSE-STRING"
jsr _popyr ; char
jsr _popxr ; len
jsr _popwr ; str
ldy #$0000
lda XR
ora XR+2
beq done
lp: lda [WR],y
and #$00FF
iny
beq done
cmp YR
beq done
cpy XR
bcc lp
ldy #$0000
done: tya
beq nomatch
sta XR+2
lda WR ; addr of str 2 = WR+(XR+2)
clc
adc XR+2
tay
lda WR+2
adc #$0000
jsr _pushay
lda XR ; len of str 2 = XR-(XR+2)
sec
sbc XR+2
jsr _pusha
ldy WR
lda WR+2
jsr _pushay
ldy XR+2
dey
: lda #$0000
PUSHNEXT
nomatch: jsr _pushay
jsr _pushay
ldy WR
lda WR+2
jsr _pushay
ldy XR
bra :-
eword
; H: ( str len -- val.lo val.hi ) parse two integers from string in the form "n2,n2"
dword PARSE_2INT,"PARSE-2INT"
ENTER
ONLIT ','
.dword LEFT_PARSE_STRING
.dword TWOPtoR
.dword ZERO
.dword StoD
.dword TWOSWAP
.dword GNUMBER
.dword THREEDROP
.dword ZERO
.dword StoD
.dword TWORtoP
.dword GNUMBER
.dword THREEDROP
EXIT
eword
; ( c-addr u wid -- xt ) search wordlist wid for word
hword dWLSEARCH,"$WLSEARCH"
jsr _popwr
ldy #$02
lda [WR],y
sta YR+2
dey
dey
lda [WR],y
sta YR
jsr _popxr
jsr _popwr
jsr _search_unsmudged
PUSHNEXT
eword
.if max_search_order > 0
; H: ( c-addr u wid -- 0 | xt +-1 ) search wordlist for word
dword SEARCH_WORDLIST,"SEARCH-WORDLIST"
.else
hword SEARCH_WORDLIST,"SEARCH-WORDLIST"
.endif
ENTER
.dword dWLSEARCH
.dword DUP
.dword _IF
.dword notfound
.dword IMMEDQ
ONLIT 1
.dword LOR
.dword NEGATE
notfound: EXIT
eword
; H: ( c-addr u -- 0 | xt +-1 ) search for word in current search order
dword SEARCH_ALL,"$SEARCH"
ENTER
.if max_search_order > 0
.dword dORDER
.dword FETCH
.dword QDUP
.dword _IF
.dword noorder
lp: .dword PtoR ; ( c-addr u1 u2 -- c-addr u1 )
.dword TWODUP ; ( c-addr u1 -- c-addr u1 c-addr' u1' )
.dword RtoP ; ( ... c-addr u1 c-addr' u1' u2 )
.dword DECR ; ( ... c-addr u1 c-addr' u1' u2' )
.dword DUP ; ( ... c-addr u1 c-addr' u1' u2' u2'' )
.dword PtoR ; ( ... c-addr u1 c-addr' u1' u2' )
.dword WLNUM ; ( ... c-addr u1 c-addr' u1' wid-addr )
.dword FETCH ; ( ... c-addr u1 c-addr' u1' wid )
.dword SEARCH_WORDLIST ; ( ... c-addr u1 0 | c-addr u1 xt +-1 )
.dword QDUP ; ( ... c-addr u1 0 | c-addr u1 xt +-1 +-1 )
.dword _IFFALSE ; ( ... c-addr u1 | c-addr u1 xt +-1 )
.dword found
.dword RtoP ; ( ... c-addr u1 u2 )
.dword DUP ; ( ... c-addr u1 u2 u2' )
.dword _IFFALSE ; ( ... c-addr u1 u2 )
.dword lp
2NIP not the same as other Forths, rename and make headerless
2020-01-08 20:25:46 +00:00
.dword NIPTWO ; ( ... u2 )
initial full commit
2019-07-01 17:33:44 +00:00
EXIT
found: .dword RDROP
.dword TWOPtoR ; ( c-addr u1 xt +-1 -- c-addr u1 )
.dword TWODROP ; ( c-addr u1 -- )
.dword TWORtoP ; ( -- xt +-1 )
EXIT
.endif
noorder: .dword FORTH_WORDLIST
.dword SEARCH_WORDLIST
EXIT
eword
; H: ( c-addr u -- xn...x1 t | f ) environmental query
dword ENVIRONMENTQ,"ENVIRONMENT?"
ENTER
.dword dENVQ_WL
.dword SEARCH_WORDLIST
.dword DUP
.dword _IF
.dword nope
.dword DROP
.dword EXECUTE
.dword TRUE
nope: EXIT
eword
; H: ( c-addr u -- xt true | c-addr u false ) find word in search order
dword dFIND,"$FIND"
ENTER
.dword TWODUP
.dword SEARCH_ALL
.dword DUP
.dword _IF
.dword notfnd
.dword DROP
2NIP not the same as other Forths, rename and make headerless
2020-01-08 20:25:46 +00:00
.dword NIPTWO
initial full commit
2019-07-01 17:33:44 +00:00
.dword TRUE ; IEEE 1275 requires true, not -1 or 1
notfnd: EXIT
eword
; H: ( c-addr -- xt ) find packed string word in search order, 0 if not found
dword FIND,"FIND"
ENTER
.dword DUP
.dword PtoR
.dword COUNT
.dword SEARCH_ALL
.dword DUP
.dword _IF
.dword notfd
.dword RDROP
EXIT
notfd: .dword RtoP
.dword SWAP
EXIT
eword
; H: ( old-name<> -- xt ) parse old-name in input stream, return xt of word
dword PARSEFIND,"'"
ENTER
.dword PARSE_WORD
.dword SEARCH_ALL
.dword QDUP
.dword _IF
.dword exc
.dword DROP
EXIT
exc: ONLIT -13
.dword THROW
eword
; H: ( [old-name<>] -- xt ) immediately parse old-name in input stream, return xt of word
dword CPARSEFIND,"[']",F_IMMED
Fix problem with ['] discovered in unit tests
2020-01-06 01:12:08 +00:00
ENTER
.dword PARSEFIND
.dword LITERAL
EXIT
initial full commit
2019-07-01 17:33:44 +00:00
eword
; H: ( xt -- a-addr) return body of word at xt, if unable then throw exception -31
dword rBODY,">BODY"
jsr _popwr ; xt -> wr
ldy #$01
lda [WR],y
and #$FF
cmp #opJSL
beq :+
ldy #.loword(-31)
lda #.hiword(-31)
jmp _throway
: lda WR
clc
adc #$05
tay
lda WR+2
adc #$00
PUSHNEXT
eword
; H: ( a-addr -- xt ) return xt of word with body at a-addr, if unable throw exc. -31
dword BODYr,"BODY>"
ENTER
ONLIT 1
.dword CELLS
.dword MINUS
.dword DUP
.dword CFETCH
ONLIT opJSL
.dword EQUAL
.dword _IF
.dword bad
.dword DECR
EXIT
bad: ONLIT -31
.dword THROW
eword
; ( a-addr -- xt ) from link field address, return xt of word
hword drXT,"$>XT"
ENTER
.dword CELLPLUS
.dword DUP
.dword CFETCH
ONLIT NAMEMSK
.dword LAND
.dword PLUS
.dword CHARPLUS
EXIT
eword
; ( xt -- xt f ) return immediacy of word at xt
hword IMMEDQ,"IMMED?"
jsr _peekwr
lda [WR]
and #F_IMMED
tf: beq :+
lda #$FFFF
: tay
PUSHNEXT
eword
; ( xt -- xt f ) return compile-only flag of word at xt
hword CONLYQ,"CONLY?"
jsr _peekwr
lda [WR]
and #F_CONLY
bra IMMEDQ::tf
eword
; ( xt -- xt f ) return temp def flag of word at xt
; words with temp def flag will trigger a temporary definition to be created in order
; to run control-flow words in interpretation state
hword TEMPDQ,"TEMPD?"
jsr _peekwr
lda [WR]
and #F_TEMPD
bra IMMEDQ::tf
eword
; needed by line editor
.proc _key
lda #SI_KEY
jsl _call_sysif
bcc :+
jmp _throway
: rts
.endproc
; H: ( -- char ) wait for input char, return it
dword KEY,"KEY"
jsr _key
NEXT
eword
; H: ( -- f ) f = true if input char is ready, false otherwise
dword KEYQ,"KEY?"
lda #SI_KEYQ
jsl _call_sysif
bcc :+
jmp _throway
: NEXT
eword
; ( -- a-addr ) variable with address of terminal input buffer
hword dTIB,"$TIB"
SYSVAR SV_dTIB
eword
; ( -- c-addr ) return address of terminal input buffer
hword TIB,"TIB"
ENTER
.dword dTIB
.dword FETCH
EXIT
eword
; ( -- a-addr ) variable with address of current input buffer
hword dCIB,"$CIB"
SYSVAR SV_dCIB
eword
; ( -- u ) variable with number of characters accepted by EXPECT
dword SPAN,"SPAN"
SYSVAR SV_SPAN
eword
; TODO: add Open Firmware editing
; H: ( addr len -- u ) get input line of up to len chars, stor at addr, u = # chars accepted
dword ACCEPT,"ACCEPT"
clc
expect1: ror YR ; if YR high bit set, do auto-termination mode
jsr _popxr
jsr _popwr
inline: ldy #$00 ; entered length
getchar: phy
jsr _key
jsr _popay
tya
ply
cmp #c_bs ; basic editing functions
beq backspc
cmp #c_del
beq backspc
cmp #c_cr
beq done
cmp #' '
bcc getchar ; ignore nonprintables
cpy XR ; if we are at max size already
bcs getchar ; then don't accept this char
sta [WR],y
phy
tay
jsr do_emit
ply
iny
cpy XR
bcc getchar
checkexp: bit YR ; in EXPECT mode?
bmi done ; yep, auto-terminate
bra getchar
backspc: cpy #$00 ; is line empty?
beq inline ; just start over if so
dey
phy ; otherwise do backspace & erase
ldy #c_bs
jsr do_emit
ldy #' '
jsr do_emit
ldy #c_bs
jsr do_emit
ply
bra getchar
done: lda #$00
jsr _pushay
bit YR
bmi expect2
ENTER
JUMP docr
expect2: ENTER
.dword SPAN
.dword STORE
docr: .dword CR
EXIT
do_emit: jsr _pushay
jsr _emit
rts
eword
; H: ( addr len -- ) get input line of up to len chars, stor at addr, actual len in SPAN
dword EXPECT,"EXPECT"
sec
jmp ACCEPT::expect1
eword
; ( -- ) set current input source to the keyboard/console
hword SETKBD,"SETKBD"
ENTER
.dword TIB
.dword dCIB
.dword STORE
dokbd: ONLIT 0
doany: .dword dSOURCEID
.dword STORE
EXIT
eword
; H: ( -- a-addr ) variable containing current input source ID
dword dSOURCEID,"$SOURCE-ID"
SYSVAR SV_SOURCEID
eword
; H: ( -- n ) return current input source id (0 = console, -1 = string, >0 = file)
dword SOURCEID,"SOURCE-ID"
ldy #SV_SOURCEID
lda [SYSVARS],y
pha
iny
iny
lda [SYSVARS],y
ply
PUSHNEXT
eword
; H: ( -- c-addr u ) return address and length of input source buffer
dword SOURCE,"SOURCE"
ENTER
.dword dCIB
.dword FETCH
.dword NIN
.dword FETCH
EXIT
eword
; H: ( -- f ) refill input buffer, f = true if that worked, false if not
dword REFILL,"REFILL"
ENTER
.dword SOURCEID
.dword DUP
.dword _IFFALSE
.dword notkbd ; return false if input source isn't console
.dword PIN ; >IN, note zero is on the stack here
.dword STORE
.dword TIB
ONLIT tib_size
.dword ACCEPT
.dword NIN ; #IN
.dword STORE
.dword TRUE
EXIT
notkbd: .dword ZEROLT
.dword _IFFALSE ; is less than zero?
.dword noinput ; yes, go throw a false on the stack
SLIT "$REFILL" ; ( -- addr len true | false )
.dword dFIND ; see if someone else handles it
.dword _IF ; $REFILL exists?
.dword noinput ; nope, nobody handles it
.dword EXECUTE ; otherwise, execute it and see what happens
.dword _IF ; that work out OK?
.dword noinput ; nope, just return false
.dword ZERO ; otherwise zero input pointer
.dword PIN
.dword STORE
.dword NIN ; set #IN to returned length
.dword STORE
.dword dCIB ; make it the input buffer
.dword STORE
EXIT
noinput: .dword FALSE
EXIT
eword
; ( -- f ) f = true if there is remaining input in the input stream, false otherwise
hword INQ,"IN?"
ENTER
.dword PIN
.dword FETCH
.dword NIN
.dword FETCH
.dword ULT
EXIT
eword
; ( -- c-addr ) return address of next character in input stream
hword INPTR,"INPTR"
ENTER
.dword PIN
.dword FETCH
.dword dCIB
.dword FETCH
.dword PLUS
EXIT
eword
; ( -- ) increment >IN
hword INC_INPTR,"INPTR+"
ENTER
.dword ONE
.dword PIN
.dword PSTORE
EXIT
eword
; ( -- char ) fetch char from input stream
hword GETCH,"GETCH"
ENTER
.dword INPTR
.dword CFETCH
.dword INC_INPTR
EXIT
eword
hword tSTATUS,">STATUS"
ENTER
SLIT "STATUS"
.dword dFIND
EXIT
eword
; ( -- ) call STATUS if defined, display OK (interpreting) or [OK] (compiling).
hword dSTATUS,"$STATUS"
ENTER
.dword SOURCEID
.dword ZEROQ
.dword _IF
.dword done ; do nothing if console is not source
.dword tSTATUS
.dword _IF
.dword nostatus
.dword EXECUTE
JUMP :+
nostatus: .dword TWODROP
: .dword SPACE
.dword _SMART
.dword interp
SLIT "[OK]"
JUMP dprompt
interp: SLIT "OK"
dprompt: .dword TYPE
.dword CR
done: EXIT
eword
; H: ( -- ) assuming STATUS is a defer, set it to .S
dword SHOWSTACK,"SHOWSTACK"
ENTER
ONLIT DOTS
set: .dword tSTATUS
.dword _IF
.dword nostatus
.dword rBODY
.dword STORE
EXIT
nostatus: .dword THREEDROP
EXIT
eword
; H: ( -- ) assuming STATUS is a defer, set it to NOOP
dword NOSHOWSTACK,"NOSHOWSTACK"
ENTER
ONLIT NOOP
JUMP SHOWSTACK::set
eword
; ( char -- ) see if char is a space (or unprintable)
hword ISSPC,"ISSPACE?"
ENTER
.dword BL
.dword INCR
.dword ULT
EXIT
eword
; H: ( "word"<> -- c-addr u ) parse word from input stream, return address and length
dword PARSE_WORD,"PARSE-WORD"
ENTER
l1: .dword INQ ; is there input?
.dword _IF
.dword none ; nope, return empty
.dword GETCH ; get char
.dword ISSPC ; is space?
.dword _IFFALSE ; if not...
.dword l1 ; do loop if it is
.dword INPTR ; get address
.dword DECR ; fixup because INPTR is 1 ahead now
.dword ONE ; we have 1 char
l2: .dword INQ ; more input?
.dword _IF
.dword e1 ; if not, exit
.dword GETCH
.dword ISSPC
.dword _IFFALSE
.dword e1 ; yes, stop
.dword INCR ; count non-spaces
JUMP l2
e1: EXIT
none: .dword INPTR
.dword ZERO
EXIT
eword
; H: ( "word"<> -- c-addr u ) alias of PARSE-WORD
dword PARSE_NAME,"PARSE-NAME"
bra PARSE_WORD::code
eword
; H: ( char "word"<char> -- c-addr u ) parse word from input stream, delimited by char
dword PARSE,"PARSE"
ENTER
.dword PtoR
.dword INPTR
.dword ZERO
l1: .dword INQ
.dword _IF
.dword e1
.dword GETCH
.dword RCOPY
.dword EQUAL
.dword _IF
.dword i1
e1: .dword RDROP
EXIT
i1: .dword INCR
JUMP l1
eword
; H: ( char "word"<char> -- c-addr ) parse word from input stream delimited by char, return
; H: address of WORD buffer containing packed string
dword WORD,"WORD"
ENTER
.dword PARSE
.dword DUP
ONLIT word_buf_size
.dword ULT
.dword _IF
.dword bad
.dword WORDBUF
.dword PACK
EXIT
bad: ONLIT -18
.dword THROW
eword
; H: ( "word"<> -- char ) parse word from input stream, return value of first char
dword CHAR,"CHAR"
ENTER
do: .dword PARSE_WORD
.dword DROP
.dword CFETCH
EXIT
eword
; H: ( "word"<> -- char ) immediately perform CHAR and compile literal
dword CCHAR,"[CHAR]",F_IMMED|F_CONLY
ENTER
do: .dword CHAR
.dword LITERAL
EXIT
eword
; H: ( "word"<> -- char ) perform either CHAR or [CHAR] per the current compile state
dword ASCII,"ASCII",F_IMMED
ENTER
.dword _SMART
.dword CHAR::do
JUMP CCHAR::do
eword
; H: ( "text"<rparen> -- ) parse and discard text until a right paren or end of input
dword LPAREN,"(",F_IMMED
ENTER
ONLIT ')'
.dword PARSE
.dword TWODROP
EXIT
eword
; H: ( "text"<rparen> -- ) parse text until a right paren or end of input, output text
dword DOTPAREN,".(",F_IMMED
ENTER
ONLIT ')'
.dword PARSE
.dword TYPE
EXIT
eword
; Helper to compile a string
; ( c-addr u -- )
hword CSTRING,"CSTRING"
jsr _2parm
ldy #.loword(docs-1)
lda #.hiword(docs-1)
jsr _str_op_ays
NEXT
docs: jsr _cbytea
clc
rtl
eword
; compile string literal as described by top two stack items
; H: C: ( c-addr1 u -- ) R: ( -- c-addr 2 u ) compile string literal into current def
dword SLITERAL,"SLITERAL",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT
.dword _SLIT
.dword DUP
.dword COMPILECOMMA
.dword CSTRING
EXIT
eword
; H: ( "text"<"> -- c-addr u )
dwordq SQ,"S'",F_IMMED
ENTER
ONLIT '"'
.dword PARSE
.dword _SMART
.dword interp
.dword SLITERAL
EXIT
interp: .dword dTMPSTR
EXIT
eword
; H: ( "text"<"> -- ) output parsed text
dwordq DOTQ,".'",F_IMMED
ENTER
.dword SQ
.dword _SMART
.dword interp
.dword _COMP_LIT
interp: .dword TYPE
EXIT
eword
; parse paired hex digits until right paren
; return string in buffer created by alloc-mem
; H: ( "text"<rparen> -- c-addr u ) parse hex, return in allocated string
dword dHEXP,"$HEX(",F_IMMED
ENTER
ONLIT 256
.dword ALLOC
ONLIT ')'
.dword PARSE
CODE
jsr _popxr ; length of parsed string
jsr _popwr ; address of parsed string
jsr _popyr ; address of allocated buffer
stz XR+2 ; will count how many digits we have stuffed
ldy #$00 ; will count the source chars processed
lp: cpy XR
beq done
sep #SHORT_A
lda [WR],y
rep #SHORT_A
and #$FF
jsr _c_to_d
bcc next ; invalid digit
cmp #$10
bcs next ; bigger than a hex digit
phy ; save index
pha ; save digit
lda XR+2
inc XR+2
lsr
tay
pla
bcc store ; even digits (from 0) just need to store
odd: sep #SHORT_A ; odd digits shift into the low nibble
asl ; C 000d => 00d0
asl
asl
asl
xba ; C 00d0 => d000
lda [YR],y ; C d000 => d00e
xba ; C d00e => 0ed0
rep #SHORT_A
lsr
lsr
lsr
lsr
store: sep #SHORT_A
sta [YR],y
rep #SHORT_A
ply ; get counter back
next: iny
bra lp
done: ldy YR
lda YR+2
jsr _pushay
lda XR+2 ; # of digits
lsr ; convert to # chars
adc #$00 ; if odd, round up
tay
lda #$00
PUSHNEXT
eword
; ( c-addr1 u1 c-addr2 u2 -- caddr1 u1+u2 )
; c-addr1 is assumed to have enough room for the string
hword SCONCAT,"SCONCAT"
jsr _4parm
lda STACKBASE+12,x ; get c-addr1+u1 to YR
clc
adc STACKBASE+8,x
sta YR
lda STACKBASE+14,x
adc STACKBASE+10,x
sta YR+2
jsr _popxr ; u2 to xr
jsr _popwr ; c-addr2 to WR
lda XR
clc
adc STACKBASE+0,x ; make u1+u2
sta STACKBASE+0,x
lda XR+2
adc STACKBASE+2,x
sta STACKBASE+2,x
resolve #6; general clean-up
2020-01-05 00:25:41 +00:00
sec ; move down is faster
jsr _memmove_c ; move the string
initial full commit
2019-07-01 17:33:44 +00:00
NEXT
eword
; H: ( "text"<"> -- c-addr u ) parse quoted text in input buffer, copy to allocated string
dwordq ASTR,"A'"
ENTER
ONLIT '"'
.dword PARSE
.dword DUP
.dword ALLOC
.dword ZERO
.dword TWOSWAP
.dword SCONCAT
EXIT
eword
; H: ( c-addr1 u1 c-addr2 u2 -- c-addr3 u1+u2 ) concatenate allocated strings
; Concatenate two strings that are in memory returned by ALLOC-MEM
; returning a string allocated via ALLOC-MEM and the original strings
; freed via FREE-MEM
dword ACONCAT,"ACONCAT"
ENTER
.dword TWOPtoR ; ( c-addr1 u1 c-addr2 u2 -- c-addr u1 ) save second string
.dword DUP ; ( ... c-addr1 u1 u1' ) copy u1
.dword RCOPY ; ( ... c-addr1 u1 u1' u2' ) get a copy of u2
.dword PLUS ; ( ... c-addr1 u1 u3 )sum them to get u1+u2
.dword ALLOC ; ( ... c-addr1 u1 c-addr3 ) allocate that many
ONLIT 0 ; ( ... c-addr1 u1 c-addr3 0 ) say it's zero length
.dword TWOSWAP ; ( ... c-addr3 0 c-addr1 u1 ) put it at the front
.dword OVER ; ( ... c-addr3 0 c-addr1 u1 c-addr1' )copy c-addr1
.dword PtoR ; ( ... c-addr3 0 c-addr1 u1 ) save for FREE-MEM
.dword SCONCAT ; ( ... c-addr3 u1 ) copy first string
.dword RtoP ; ( ... c-addr3 u1 c-addr1 )
ONLIT 0
.dword FREE ; ( ... c-addr3 u1 ) free it
.dword TWORtoP ; ( ... c-addr3 u1 c-addr2 u2 )
.dword OVER ; ( ... c-addr3 u1 c-addr2 u2 c-addr2' )
.dword PtoR ; ( ... c-addr3 u1 c-addr2 u2 )
.dword SCONCAT ; ( ... c-addr3 u1+u2 )
.dword RtoP ; ( ... c-addr3 u1+u2 c-addr2 )
ONLIT 0
.dword FREE ; ( ... c-addr3 u1+u2 )
EXIT
eword
; H: ( "text"<"> -- c-addr u ) parse string, including hex interpolation
dwordq QUOTE,"'",F_IMMED
ENTER
.dword ZERO ; ( -- 0 )
.dword ALLOC ; ( 0 -- c-addr1 ) empty allocation
.dword ZERO ; ( c-addr1 -- c-addr1 0 )
moretext: .dword ASTR ; ( c-addr1 u1 -- c-addr1 u1 c-addr2 u2 )
.dword ACONCAT ; ( ... c-addr3 u3 )
.dword INQ ; ( ... c-addr3 u3 f )
.dword _IF ; ( ... c-addr3 u3 )
.dword finish ; no more text to parse, finish up
.dword GETCH ; ( ... c-addr3 u3 c )
.dword DUP ; ( ... c-addr3 u3 c c' )
.dword ISSPC ; ( ... c-addr3 u3 c f )
.dword _IFFALSE ; ( ... c-addr3 u3 c )
.dword space ; is a space, drop space and return string
ONLIT '(' ; ( ... c-addr3 u3 c '(' )
.dword EQUAL ; ( ... c-addr3 u3 f )
.dword _IF ; ( ... c-addr3 u3 )
.dword finish ; finish, but we will probably error later in parsing
.dword dHEXP ; ( ... c-addr3 u3 c-addr4 u4 )
.dword ACONCAT ; ( ... c-addr5 u5 )
JUMP moretext ; and switch back to parsing quoted string
space: .dword DROP
finish: .dword OVER ; ( c-addr3 u3 -- c-addr3 u3 c-addr3' )
.dword PtoR ; ( ... c-addr3 u3 ) ( R: -- c-addr3' )
.dword _SMART
.dword interp
.dword SLITERAL ; ( c-addr3 u3 -- )
JUMP done
interp: .dword dTMPSTR
done: .dword RtoP ; ( -- c-addr3' ) ( R: c-addr3' -- )
ONLIT 0
.dword FREE ; ( c-addr3' -- )
EXIT
eword
clarifications in comments
2020-01-06 17:56:35 +00:00
; H: ( -- ) Compile code to compile the immediately following word. Better to use POSTPONE.
initial full commit
2019-07-01 17:33:44 +00:00
; BTW don't use with numbers.
dword COMPILE,"COMPILE",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT ; Compile a _COMP_LIT
.dword _COMP_LIT
EXIT
eword
clarifications in comments
2020-01-06 17:56:35 +00:00
; H: ( "name"<> -- ) Compile name now. Better to use POSTPONE.
initial full commit
2019-07-01 17:33:44 +00:00
dword ICOMPILE,"[COMPILE]",F_IMMED
ENTER
.dword PARSEFIND
.dword COMPILECOMMA
EXIT
eword
; H: ( "name"<> -- )
; Compile the compilation semantics of name
; Basically, if the word is immediate, compile its xt
; If not, compile code that compiles its xt
dword POSTPONE,"POSTPONE",F_IMMED
ENTER
.dword PARSE_WORD
.dword SEARCH_ALL
.dword QDUP
.dword _IF
.dword exc
.dword ZEROLT
.dword _IF
.dword immed ; if >0, it is an IMMEDIATE word, go compile xt
.dword LITERAL ; compile its xt as a literal
.dword _COMP_LIT ; and compile COMPILE,
immed: .dword COMPILECOMMA
EXIT
exc: ONLIT -13
.dword THROW
eword
; H: ( -- ) output the words in the CONTEXT wordlist
dword WORDS,"WORDS"
ENTER
.dword CONTEXT
.dword FETCH
lp: .dword DUP ; ( h -- h h )
.dword _IF ; ( h h -- h )
.dword done
.dword DUP ; ( h -- h h )
.dword drXT ; ( h -- h xt )
.dword DUP ; ( h xt -- h xt xt )
.dword UDOT ; ( h xt xt -- h xt )
.dword rNAME ; ( h xt -- h c-addr u )
.dword TYPE ; ( h c-addr u -- h )
.dword CR
.dword EXITQ ; ( h -- h f )
.dword _IFFALSE
.dword done
.dword FETCH ; ( h -- h' )
JUMP lp
done: .dword DROP ; ( h -- )
EXIT
eword
.if include_see
; H: ( xt -- ) attempt to decompile the word at xt
dword dSEE,"(SEE)"
ENTER
.dword QDUP
.dword _IF
.dword notxt
SLIT "Flags: " ; ( xt -- xt str len )
.dword TYPE ; ( str len -- )
.dword DUP ; ( xt -- xt xt' )
.dword CFETCH ; ( xt xt' -- xt u )
.dword UDOT ; ( xt u -- xt )
.dword CR
.dword DUP ; ( xt -- xt xt' )
.dword rNAME ; ( xt xt' -- xt str len )
.dword ROT ; ( xt str len -- str len xt )
.dword INCR ; ( str len xt -- str len a-addr )
.dword DUP ; ( ... str len a-addr a-addr' )
.dword FETCH ; ( ... str len a-addr u )
ONLIT (_enter << 8)+opJSL ; ( ... str len a-addr u x )
.dword EQUAL ; ( ... str len a-addr f )
.dword _IF ; ( ... str len a-addr )
.dword cant
ONLIT ':' ; ( ... str len a-addr ':' )
.dword EMIT ; ( ... str len a-addr )
.dword SPACE
.dword NROT ; ( ... a-addr str len )
.dword TYPE ; ( ... a-addr )
.dword CR
lp: .dword CELLPLUS ; ( a-addr(old) -- a-addr )
.dword DUP ; ( ... a-addr a-addr' )
.dword FETCH ; ( ... a-addr u )
ONLIT _exit_next-1
.dword _IFEQUAL
.dword :+
.dword DROP
ONLIT ';'
.dword EMIT
quit: .dword DROP
notxt: EXIT
: .dword OVER ; ( ... a-addr u a-addr' )
.dword UDOT ; ( ... a-addr u )
ONLIT _LIT
.dword _IFEQUAL
.dword :+
.dword DROP
.dword CELLPLUS
.dword DUP
.dword FETCH
.dword DOT
JUMP crlp
: ONLIT _WLIT
.dword _IFEQUAL
.dword :+
.dword DROP
.dword CELLPLUS
.dword DUP
.dword WFETCH
.dword DOT
.dword TWODECR
JUMP crlp
: ONLIT _CLIT
.dword _IFEQUAL
.dword :+
.dword DROP
.dword CELLPLUS
.dword DUP
.dword CFETCH
.dword DOT
.dword THREE
.dword MINUS
JUMP crlp
: ONLIT _SLIT
.dword _IFEQUAL
.dword :+
.dword DROP ; ( ... a-addr )
.dword CELLPLUS ; skip _SLIT
.dword DUP
.dword FETCH ; ( ... a-addr len ) get length of string
.dword SWAP ; ( ... len a-addr )
;.dword CELLPLUS ; ( ... len a-addr )
.dword TWODUP ; ( ... len a-addr len a-addr )
.dword CELLPLUS
.dword SWAP ; ( ... len a-addr a-addr len )
ONLIT '"'
.dword EMIT
.dword TYPE ; ( ... len a-addr )
ONLIT '"'
.dword EMIT
.dword PLUS
JUMP crlp
: .dword rNAME ; ( ... a-addr str len )
.dword TYPE ; ( ... a-addr )
crlp: .dword CR
.dword EXITQ ; ( ... a-addr f )
.dword _IFFALSE ; ( ... a-addr )
.dword quit
JUMP lp
cant: .dword DROP ; drop pointer
SLIT "Can't see "
.dword TYPE
.dword TYPE
EXIT
eword
; H: ( "name"<> -- ) attempt to decompile name
dword SEE,"SEE"
ENTER
.dword PARSEFIND
.dword dSEE
EXIT
eword
.endif
; H: ( c-addr u -- ) like CREATE but use c-addr u for name
dword dCREATE,"$CREATE"
jsr _mkentry
docreate: ldy #.loword(_pushda)
lda #.hiword(_pushda)
jsr _cjsl
NEXT
eword
; H: ( "name"<> -- ) create a definition, when executed pushes the body address
dword CREATE,"CREATE"
ENTER
.dword PARSE_WORD
.dword dCREATE
EXIT
eword
; H: ( "name"<> -- ) execute CREATE name and ALLOT one cell, initially a zero.
dword VARIABLE,"VARIABLE"
ENTER
.dword CREATE
.dword ZERO
.dword COMMA
EXIT
eword
; action of DOES
; modify the most recent definition (CREATED) to jsl to the address immediately
; following whoever JSLed to this and return to caller
.proc _does
ENTER
.dword LAST
.dword drXT
.dword INCR
CODE
jsr _popyr
pla
sta WR
sep #SHORT_A
pla
rep #SHORT_A
and #$00FF
sta WR+2
jsr _incwr
ldy #$00
lda [YR],y
and #$00FF
cmp #opJSL
bne csmm
lda WR
iny
sta [YR],y
lda WR+2
iny
iny
sep #SHORT_A
sta [YR],y
rep #SHORT_A
NEXT
csmm: jmp _CONTROL_MM::code
.endproc
; H: ( -- ) alter execution semantics of most recently-created definition to perform
; H: the following execution semantics.
dword DOES,"DOES>",F_IMMED|F_CONLY
ENTER
.dword SEMIS
.dword _COMP_LIT
jsl f:_does ; better be 4 bytes!
.dword _COMP_LIT
ENTER ; not really, now
.dword _COMP_LIT
.dword RPLUCKADDR
.dword _COMP_LIT
.dword INCR
.dword STATEC ; ensure still in compiling state
EXIT
eword
; ( -- ) throw exception -13
hword dUNDEFERRED,"$UNDEFERRED"
ldy #.loword(-13)
lda #.hiword(-13)
jmp _throway
eword
; ( xt str len -- ) -- create a deferred word with xt as its initial behavior
hword dDEFER,"$DEFER"
jsr _3parm
jsr _mkentry
dodefer: ldy #.loword(_deferred)
lda #.hiword(_deferred)
jsr _cjsl
jsr _popay
jsr _ccellay
NEXT
eword
; H: ( "name"<> -- ) create definition that executes the first word of the body as an xt
dword DEFER,"DEFER"
ENTER
NLIT dUNDEFERRED
.dword PARSE_WORD
.dword dDEFER
EXIT
eword
; H: ( "name"<> -- ) return the first cell of the body of name, which should be a DEFER word
dword BEHAVIOR,"BEHAVIOR"
ENTER
.dword rBODY
.dword FETCH
EXIT
eword
; H: ( str len xt -- ) create a DEFER definition for string with xt as its initial behavior
dword IS_USER_WORD,"(IS-USER-WORD)"
ENTER
.dword NROT ; reorder for $DEFER
.dword dDEFER
EXIT
eword
; H: ( n str len ) create a definition that pushes the first cell of the body, initially n
dword dVALUE,"$VALUE"
jsr _3parm ; avoid dictionary corruption from stack underflow
jsr _mkentry
dovalue: ldy #.loword(_pushvalue)
lda #.hiword(_pushvalue)
jsr _cjsl
jsr _popay
jsr _ccellay
NEXT
eword
; H: ( n1 n2 str len ) create a definition that pushes the first two cells of the body
; H: initially n1 and n2
dword dTWOVALUE,"$2VALUE"
jsr _4parm ; avoid dictionary corruption from stack underflow
jsr _mkentry
ldy #.loword(_push2value)
lda #.hiword(_push2value)
jsr _cjsl
jsr _popay
jsr _ccellay
jsr _popay
jsr _ccellay
NEXT
eword
; H: ( n "name"<> -- ) create a definition that pushes n on the stack, n can be changed
; H: with TO
dword VALUE,"VALUE"
ENTER
.dword PARSE_WORD
.dword dVALUE
EXIT
eword
; H: ( n -- ) allocate memory immediately, create definition that returns address of memory
dword BUFFERC,"BUFFER:"
ENTER
.dword ALLOC
.dword VALUE
EXIT
eword
; H: ( n "name"<> -- ) alias of VALUE, OF816 doesn't have true constants
; we don't have real constants, they can be modified with TO
dword CONSTANT,"CONSTANT"
bra VALUE::code
eword
; FCode support, these are needed to support the INSTANCE feature when it is installed
; and so are included in the main dictionary. By default the FCodes for b(value),
; b(buffer), b(variable), and b(defer) point to these. When the INSTANCE feature
; is installed, it will call set-token to replace these, but will still need to call them
; in the case that INSTANCE was not used.
.if include_fcode
; ( -- ) compile the machine execution semantics of CREATE (jsl _pushda)
don't index certain words in source
2020-01-09 01:46:24 +00:00
hword pCREATE,"%CREATE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
jmp dCREATE::docreate
eword
; H: ( n -- ) compile the machine execution semantics of VALUE (jsl _pushvalue) and the value
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword pVALUE,"%VALUE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
jsr _1parm
jmp dVALUE::dovalue
eword
; H: ( n -- ) compile the machine execution semantics of BUFFER (jsl _valuevalue) and the
; H: buffer address
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword pBUFFER,"%BUFFER" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword ALLOC
.dword pVALUE
EXIT
eword
; H: ( -- ) compile the machine execution semantics of CREATE (jsl _pushda) and compile a zero
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword pVARIABLE,"%VARIABLE" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword pCREATE
.dword ZERO
.dword COMMA
EXIT
eword
; H: ( -- ) compile the machine execution semantics of DEFER (jsl _deferred)
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword pDEFER,"%DEFER" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ldy #.loword(dUNDEFERRED)
lda #.hiword(dUNDEFERRED)
jsr _pushay
jmp dDEFER::dodefer
eword
.endif
; H: ( n1 n2 "name"<> -- ) create name, name does ( -- n1 n2 ) when executed
dword TWOCONSTANT,"2CONSTANT"
ENTER
.dword PARSE_WORD
.dword dTWOVALUE
EXIT
eword
; H: ( "name1"<> "name2"<> -- ) create name1, name1 is a synonym for name2
dword ALIAS,"ALIAS"
ENTER
.dword PARSE_WORD
.dword PARSEFIND
.dword INCR
.dword NROT
CODE
jsr _mkentry
jsr _popay
jsr _cjml
NEXT
eword
; ( n xt -- ) change the first cell of the body of xt to n
hword _TO,"_TO"
ENTER
.dword rBODY
.dword STORE
EXIT
eword
; H: ( n "name"<> -- ) change the first cell of the body of xt to n. Can be used on
; most words created with CREATE, DEFER, VALUE, etc. even VARIABLE
dword TO,"TO",F_IMMED
ENTER
.dword PARSEFIND
doto: .dword _SMART
.dword setval
.dword LITERAL
.dword _COMP_LIT
setval: .dword _TO
EXIT
eword
; H: ( -- 0 )
dword STRUCT,"STRUCT"
lda #$0000
tay
PUSHNEXT
eword
; ( offset size c-addr u -- offset+size ) create word specified by c-addr u with
; execution semantics: ( addr -- addr+offset)
hword dFIELD,"$FIELD"
jsr _4parm
jsr _mkentry
dofield: ldy #.loword(_field)
lda #.hiword(_field)
jsr _cjsl
ldy STACKBASE+4,x
lda STACKBASE+6,x
jsr _ccellay
lda STACKBASE+0,x
clc
adc STACKBASE+4,x
sta STACKBASE+4,x
lda STACKBASE+2,x
adc STACKBASE+6,x
sta STACKBASE+6,x
jsr _stackincr
NEXT
eword
; H: ( offset size "name"<> -- offset+size ) create name, name exec: ( addr -- addr+offset)
dword FIELD,"FIELD"
ENTER
.dword PARSE_WORD
.dword dFIELD
EXIT
eword
; ( str len -- xt ) define word with empty execution semantics
hword dDEFWORD,"$DEFWORD"
ldy #SV_OLDHERE
lda DHERE
sta [SYSVARS],y
iny
iny
lda DHERE+2
sta [SYSVARS],y
jsr _mkentry
jsr _pushay ; flags/XT
NEXT
eword
; ( -- ) compile colon definition execution semantics (JSL _enter)
hword dCOLON,"$COLON"
ldy #.loword(_enter)
lda #.hiword(_enter)
jsr _cjsl
NEXT
eword
; ( xt -- ) hide visibility of definition at xt
hword SMUDGE,"SMUDGE"
ENTER
.dword DUP ; dup XT (flags addr)
.dword CFETCH ; so we can smudge it
ONLIT F_SMUDG
.dword LOR
.dword SWAP
.dword CSTORE
EXIT
eword
; H: ( "name"<> -- colon-sys ) parse name, create colon definition and enter compiling state
dword COLON,":"
ENTER
.dword PARSE_WORD
.dword dDEFWORD
.dword dCOLON
.dword DUP ; one for setting flags, one for colon-sys
.dword SMUDGE
.dword DUP ; and one for RECURSE
.dword dCURDEF
.dword STORE
.dword STATEC
EXIT
eword
; H: ( -- colon-sys ) create an anonymous colon definition and enter compiling state
; H: the xt of the anonymous definition is left on the stack after ;
dword NONAME,":NONAME"
ENTER
ONLIT $80 ; name length is 0 for noname
.dword CCOMMA
.dword HERE ; XT/flags
.dword DUP ; one for user, one for colon-sys
.dword DUP ; and one for RECURSE
.dword dCURDEF
.dword STORE
ONLIT $00 ; noname flags
.dword CCOMMA
.dword STATEC
.dword dCOLON
EXIT
eword
; H: ( -- colon-sys ) create a temporary anonymous colon definition and enter compiling state
; H: the temporary definition is executed immediately after ;
; word supporting temporary colon definitions to implement IEEE 1275
; words that are extended to run in interpretation state
dword dTEMPCOLON,":TEMP"
ENTER
;SLIT "Starting temp def... "
;.dword TYPE
ONLIT max_tempdef ; allocate 128 cells worth of tempdef
.dword ALLOC
.dword DUP
.dword dTMPDEF ; and save its allocation
.dword STORE
.dword HERE ; save HERE
.dword dSAVEHERE
.dword STORE
.dword toHERE ; and then set it to the temp def allocation
.dword NONAME ; start anonymous definition
.dword DEPTH ; save stack depth (data stack is control stack)
.dword dCSDEPTH
.dword STORE
resolve #7
2020-01-06 05:53:07 +00:00
done: EXIT
initial full commit
2019-07-01 17:33:44 +00:00
eword
; word to end temporary colon definition and run it
simplify temp def stuff a little
2020-01-06 05:12:49 +00:00
; called whenever control-flow-ending words are executed
; and a temporary definition is open
initial full commit
2019-07-01 17:33:44 +00:00
; ( xt xt' -- )
simplify temp def stuff a little
2020-01-06 05:12:49 +00:00
hword dTEMPSEMIQ,"$;TEMP?",F_IMMED|F_CONLY
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
.dword dTMPDEF ; ( -- a-addr )
simplify temp def stuff a little
2020-01-06 05:12:49 +00:00
.dword FETCH ; ( a-addr -- x ) 0 if not in temp def
.dword _IF ; ( x -- )
.dword notmp ; if not in temp def
initial full commit
2019-07-01 17:33:44 +00:00
dosemi: .dword DEPTH ; ( -- u1 )
.dword dCSDEPTH ; ( u1 -- u1 c-addr1 ) verify stack depth is what it should be
.dword FETCH ; ( u1 c-addr1 -- u1 u2 )
.dword ULTE ; ( u1 u2 -- f ) is less than or equal to?
.dword _IFFALSE ; ( f -- )
.dword tmpdone ; true branch, finish up temp def
simplify temp def stuff a little
2020-01-06 05:12:49 +00:00
notmp: EXIT
initial full commit
2019-07-01 17:33:44 +00:00
tmpdone: ;SLIT "Ending temp def... "
;.dword TYPE
.dword DEPTH ; ( -- u1 )
.dword dCSDEPTH ; ( u1 -- u1 c-addr1 ) verify stack depth is what it should be
.dword FETCH ; ( u1 c-addr1 -- u1 u2 )
resolve #7
2020-01-06 05:53:07 +00:00
;.dword DOTS
initial full commit
2019-07-01 17:33:44 +00:00
.dword EQUAL ; ( u1 u2 -- f )
.dword _IF ; ( f -- )
.dword csmm ; if not, we have a problem
.dword _COMP_LIT ; compile EXIT into temporary def
EXIT ; NOTE: not really EXITing here
.dword STATEI ; ( -- )
.dword dSAVEHERE ; ( -- a-addr ) restore HERE
.dword FETCH ; ( a-addr -- c-addr )
.dword toHERE ; ( c-addr -- )
.dword dTMPDEF ; ( -- a-addr ) get location of temporary definition
.dword DUP ; ( -- a-addr a-addr' ) one for FREE, one to write zero into it
.dword FETCH ; ( a-addr a-addr' -- a-addr c-addr )
.dword PtoR ; ( a-addr c-addr -- a-addr ) ( R: -- c-addr ) safe for FREE
.dword OFF ; ( a-addr -- ) zero $TEMPDEF
.dword DROP ; ( xt xt -- xt ) now we worry about ( xt xt ) consume colon-sys
.dword CATCH ; ( xt -- * r ) execute the temporary definition within catch
.dword RtoP ; ( r -- r c-addr ) ( R: c-addr -- )
resolve #7
2020-01-06 05:53:07 +00:00
dofree: ONLIT max_tempdef ; ( r c-addr -- r c-addr u )
initial full commit
2019-07-01 17:33:44 +00:00
.dword FREE ; ( r c-addr u -- r )
.dword THROW ; ( r -- ) re-throw any error in temp def
resolve #7
2020-01-06 05:53:07 +00:00
EXIT ; this really is an exit
initial full commit
2019-07-01 17:33:44 +00:00
csmm: .dword STATEI ; ( -- )
.dword dSAVEHERE ; ( -- a-addr ) restore HERE
.dword FETCH ; ( a-addr -- c-addr )
.dword toHERE ; ( c-addr -- )
ONLIT -22 ; ( -- -22 ) will be thrown
.dword dTMPDEF ; ( -22 -- -22 c-addr )
resolve #7
2020-01-06 05:53:07 +00:00
JUMP dofree ; note that thrown error will clean up dTMPDEF
initial full commit
2019-07-01 17:33:44 +00:00
eword
; ( xt -- ) make definition at xt visible
hword UNSMUDGE,"UNSMUDGE"
ENTER
.dword DUP ; dup XT (flags addr)
.dword CFETCH ; so we can unsmudge it
ONLIT F_SMUDG
.dword INVERT
.dword LAND
.dword SWAP
.dword CSTORE
EXIT
eword
; H: ( colon-sys -- ) consume colon-sys and enter interpretation state, ending the current
; H: definition. If the definition was temporary, execute it.
dword SEMI,";",F_IMMED|F_CONLY
ENTER
.dword dTMPDEF ; see if it's a temporary definition
.dword FETCH
.dword _IF
.dword :+
simplify temp def stuff a little
2020-01-06 05:12:49 +00:00
.dword dTEMPSEMIQ ; if it is, do that instead
initial full commit
2019-07-01 17:33:44 +00:00
EXIT
: .dword _COMP_LIT ; compile EXIT into current def
EXIT ; NOTE: not really EXITing here
dosemi: .dword UNSMUDGE ; consume colon-sys
.dword STATEI ; exit compilation state
ONLIT 0
.dword dOLDHERE
.dword STORE
EXIT
eword
; H: ( -- ) make the current definition findable during compilation
dword RECURSIVE,"RECURSIVE",F_IMMED|F_CONLY
ENTER
.dword dCURDEF
.dword FETCH
.dword UNSMUDGE
EXIT
eword
; H: ( -- ) compile the execution semantics of the most recently-created definition
dword RECURSE,"RECURSE",F_IMMED|F_CONLY
ENTER
.dword dCURDEF
.dword FETCH
.dword COMPILECOMMA
EXIT
eword
; H: ( "name"<> -- code-sys ) create a new CODE definiion
; TODO: activate ASSEMBLER words if available
dword CODEDEF,"CODE"
ENTER
.dword PARSE_WORD
.dword dDEFWORD
docode: .dword DUP ; one for setting flags, one for colon-sys
.dword SMUDGE
; .dword STATEC
EXIT
eword
; H: ( "name"<> -- code-sys ) create a new LABEL definition
dword LABEL,"LABEL"
ENTER
.dword PARSE_WORD
.dword dCREATE
.dword LAST
.dword drXT
JUMP CODEDEF::docode
eword
; H: ( code-sys -- ) consume code-sys, end CODE or LABEL definition
dword CSEMI,"C;"
jsr _1parm
ldy #.loword(_next)
lda #.hiword(_next)
jsr _cjml
ENTER
JUMP SEMI::dosemi
eword
; H: ( code-sys -- ) synonym for C;
dword ENDCODE,"END-CODE",F_IMMED|F_CONLY
bra CSEMI::code
eword
; ( xt -- ) mark XT as immediate
hword dIMMEDIATE,"$IMMEDIATE"
ENTER
.dword DUP ; dup XT (flags addr)
.dword CFETCH
ONLIT F_IMMED
.dword LOR
.dword SWAP
.dword CSTORE
EXIT
eword
; H: ( -- ) mark last compiled word as an immediate word
dword IMMEDIATE,"IMMEDIATE"
ENTER
.dword LAST
.dword drXT
.dword dIMMEDIATE
EXIT
eword
; ( xt -- ) mark word at xt as protected
hword dPROTECTED,"$PROTECTED"
ENTER
.dword DUP ; dup XT (flags addr)
.dword CFETCH
ONLIT F_PROT
.dword LOR
.dword SWAP
.dword CSTORE
EXIT
eword
; ( -- ) mark last created word as protected (e.g. from FORGET)
hword PROTECTED,"PROTECTED"
ENTER
.dword LAST
.dword drXT
.dword dPROTECTED
EXIT
eword
; ( -- ) for DOES> and ;CODE
hword SEMIS,"SEMIS"
ENTER
.dword _COMP_LIT
CODE ; not really, see NOTE above
.dword RECURSIVE ; allow word to be found
EXIT
eword
; TODO attempt to activate assembler package
; H: ( -- ) end compiler mode, begin machine code section of definition
dword SCODE,";CODE",F_IMMED|F_CONLY
bra SEMIS::code
eword
.if 0
; ANS Forth locals
; ( u -- ) ( R: -- old_locals_ptr u*0 u2 )
; u2 = old SP after
hword dCREATE_LOCALS,"$CREATE-LOCALS"
lda locals_ptr ; current locals pointer (in stack)
pha ; save it
tsc ; current stack pointer (for fast cleanup)
sta WR ; save for now
jsr _popay ; get number of locals
lda #$0000 ; gonna zero them all out
lp: dey
bmi done
pha ; for each local, throw a cell on the stack
pha
bra lp
done: tsc ; now set up locals pointer to new block of locals
inc a ; 'cause '02 stack ptr is at the free byte
sta locals_ptr
lda WR
pha
NEXT
eword
; ( u -- ) ( R: u*n -- )
hword dDESTROY_LOCALS,"$DESTROY-LOCALS"
pla ; this is the old SP after saved locals poubter
tcs ; restore return stack
pla ; get old locals pointer
sta locals_ptr ; and make it current
eword
; ( u -- ) common routine to set up WR and Y register to access a local by number
.proc _localcom
lda locals_ptr ; get current locals pointer
sta WR ; set up WR to point to it
stz WR+2
jsr _popay ; get local number
tya ; and compute offset into locals
asl
tay
rts
.endproc
; ( u -- n ) fetch from local
hword dLOCALFETCH,"$LOCAL@"
jsr _localcom ; set up WR and Y reg
lda [WR],y ; low byte
pha ; save for now
iny ; move to high byte
iny
lda [WR],y ; get it
ply ; get low byte back
PUSHNEXT ; and toss on stack
eword
; ( n u -- )
hword dLOCALSTORE,"$LOCAL!"
jsr _swap ; get value to top
jsr _popay ; and put on return stack for now
pha
phy
jsr _localcom ; set up WR and Y reg
pla ; get low byte of value back
sta [WR],y ; store it
iny ; move to high byte
iny
pla ; get it back
sta [WR],y ; and store
NEXT
eword
.endif
.if enable_quotations
; Quotations enable syntax as follows:
; during compilation: [: ( -- quot-sys ) ... ;] ( quot-sys -- ) define a quotation
; (anonymous def within a definition)
; run time: ( -- xt ) leave xt of the quotation on the stack
; note that SEE cannot decode words with quotations.
; This implementation skips the quotation with AHEAD and afterwards leaves the
; the xt on the stack.
; quot-sys is ( -- old-$CURDEF forward-ref xt )
dword SQUOT,"[:",F_IMMED|F_CONLY
ENTER
.dword dCURDEF ; fix current def to quotation
.dword FETCH ; save current def for RECURSE
.dword AHEAD ; leaves address to resolve later
.dword NONAME ; start an anonymous definition
.dword DROP ; leave only one copy
EXIT
eword
dword EQUOT,";]",F_IMMED|F_CONLY
ENTER
.dword _COMP_LIT ; compile EXIT into current def
EXIT ; NOTE: not really EXITing here
.dword SWAP ; put ahead target on top
.dword THEN ; resolve AHEAD
.dword LITERAL ; consume XT of word, place on stack at run-time
.dword dCURDEF ; restore current def to parent
.dword STORE ; and consume that
EXIT
eword
.endif
.if max_search_order > 0
; ( -- wid )
; ( root -- wid ) create a wordlist rooted at root
hword dCREATE_WL,"$CREATE-WL"
ENTER
.dword HERE ; WID
.dword SWAP
.dword COMMA ; compile pointer to root
.dword _COMP_LIT
.dword 0 ; pointer to xt of vocabulary def, none in this case
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( -- wid ) Create a new wordlist.
initial full commit
2019-07-01 17:33:44 +00:00
; wordlists are allocated from the dictionary space, containing two cells
; the first being the last word defined in the wordlist, and the second containing
; an xt to an associated vocabulary definition if one has been defined
; the wid is the pointer to the first cell
dword WORDLIST,"WORDLIST"
ENTER
ONLIT H_FORTH ; root of all dictionaries
.dword dCREATE_WL
.dword 0
EXIT
eword
; H: ( -- wid ) create a new empty wordlist (danger!)
; non-standard method to create a completely empty wordlist. If this is the only
; list in the search order, it may be impossible to get out of the situation
dword dEMPTY_WL,"$EMPTY-WL"
ENTER
.dword ZERO ; null root
.dword dCREATE_WL
EXIT
eword
start docgen automation
2020-01-14 00:58:39 +00:00
; H: ( "name"<> -- ) Create a new named wordlist definition. When name is executed,
; H: put the WID of the wordlist at the top of the search order.
; H: The WID is the address of teh body of the named wordlist definition.
initial full commit
2019-07-01 17:33:44 +00:00
dword VOCABULARY,"VOCABULARY"
ENTER
.dword CREATE
Support easily adding extra dictionaries, e.g. as part of platform
2019-12-11 00:02:31 +00:00
dovocab: .dword _COMP_LIT
initial full commit
2019-07-01 17:33:44 +00:00
.dword H_FORTH ; root of all dictionaries
.dword LAST
.dword drXT ; XT of the just-created word
.dword COMMA
CODE
jsl f:_does
ENTER ; action of the vocabulary definition
.dword RPLUCKADDR
.dword INCR
.dword TOP_OF_ORDER
EXIT
eword
Support easily adding extra dictionaries, e.g. as part of platform
2019-12-11 00:02:31 +00:00
; H: ( c-addr u -- ) create a new named wordlist definition as per VOCABULARY
; H: meant for adding more builtin dictionaries (e.g. platform specific dictionaries)
; H: which are expected to adjust the root to the new wordlist
hword dVOCAB,"$VOCAB"
ENTER
.dword dCREATE
JUMP VOCABULARY::dovocab
eword
initial full commit
2019-07-01 17:33:44 +00:00
.endif
.if 0 ; half-baked
; ( -- )
; "Restore all dictionary allocation and search order pointers to the state they had just
; prior to the definition of name. Remove the definition of name and all subsequent
; definitions. Restoration of any structures still existing that could refer to deleted
; definitions or deallocated data space is not necessarily provided. No other contextual
; information such as numeric base is affected."
; May need to change the wordlist structures to be a linked list so that we are aware of
; all of them, because at least one of them will have their head change and may not be
; in the search order.
; So in total when the marker is created we need to:
; * save HERE in order to deallocate the space later
; * save CURRENT to restore compiler word list
; * save the search order
; * save the heads of all wordlists
; * save the head of the wordlists list
; When the marker is executed, restore all of the above:
; * restoring head of the wordlists ensures removal of all wordlists
; that are removed by the marker
; * restoring the heads of the (remaining) wordlists removes all definitions created
; after the marker
; * restoring the search order and CURRENT ensures no removed wordlists are in use
; * Restoring HERE deallocates all dictionary space from the marker and beyond.
don't index certain words in source
2020-01-09 01:46:24 +00:00
dword MARKER,"MARKER" ; noindex
initial full commit
2019-07-01 17:33:44 +00:00
ENTER
CODE
jsl f:_does
ENTER ; action of the marker
EXIT
eword
.endif
; H: ( "..."<end> -- ) discard the rest of the input buffer (line during EVALUATE)
dword BACKSLASH,"\",F_IMMED
ENTER
.dword SOURCEID
.dword _IF
.dword term ; faster
ONLIT 0 ; something to drop...
lp: .dword DROP
.dword INQ
.dword _IF
.dword done
.dword GETCH
.dword DUP
ONLIT c_cr
.dword EQUAL
.dword _IFFALSE
.dword ddone ; if true (= CR)
.dword DUP
ONLIT c_lf
.dword EQUAL
.dword _IF
.dword lp ; if false (<> LF)
ddone: .dword DROP
done: EXIT
term: .dword NIN
.dword FETCH
.dword PIN
.dword STORE
EXIT
eword
; H: ( char -- char' ) upper case convert char
dword UPC,"UPC"
jsr _1parm
lda STACKBASE+0,x
jsr _cupper
sta STACKBASE+0,x
NEXT
eword
; H: ( char -- char' ) lower case convert char
dword LCC,"LCC"
jsr _1parm
lda STACKBASE+0,x
cmp #'A'
bcc done
cmp #'Z'+1
bcs done
ora #$20
sta STACKBASE+0,X
done: NEXT
eword
; H: ( "name"<> ) parse name, place low 5 bits of first char on stack, if compiling stat
; H: compile it as a literal
dword CONTROL,"CONTROL",F_IMMED
ENTER
.dword CHAR
ONLIT $1F
.dword LAND
.dword _SMART
.dword interp
.dword LITERAL
interp: EXIT
eword
; H: ( char base -- digit true | char false ) attempt to convert char to digit
dword DIGIT,"DIGIT"
jsr _2parm
lda STACKBASE+4,x
jsr _c_to_d
ldy #$0000
bcc bad
cmp STACKBASE+0,x
bcs bad
sta STACKBASE+4,x
dey
bad: sty STACKBASE+0,x
sty STACKBASE+2,X
NEXT
eword
; H: ( addr len -- true | n false ) attmept to convert string to number
dword dNUMBER,"$NUMBER"
ENTER
.dword OVER
.dword CFETCH
ONLIT '-'
.dword EQUAL
.dword PtoR
.dword RCOPY
.dword _IF
.dword :+
.dword DECR
.dword SWAP
.dword INCR
.dword SWAP
: .dword TWOPtoR ; ( c-addr u -- )
.dword ZERO ; ( -- 0 )
.dword StoD ; ( 0 -- ud )
.dword TWORtoP ; ( ud -- ud c-addr u )
.dword GNUMBER ; ( ud c-addr u -- ud' c-addr' u' ) u' = 0 if no unconverted
.dword _IF ; ( ud' c-addr' u' -- ud' c-addr' )
.dword okay
.dword THREEDROP ; ( ud' c-addr' -- )
.dword RDROP ; lose negative
.dword TRUE ; ( -- tf )
EXIT
okay: .dword DROP ; ( ud' c-addr' -- ud' )
.dword DtoS ; ( ud' -- n )
.dword RtoP
.dword QNEGATE
.dword FALSE ; ( n -- n ff )
EXIT
eword
; ( xx...xx1 -- yx...yx1 )
; Interpret text from current input source
hword INTERPRET,"INTERPRET"
ENTER
loop: .dword INQ ; ( -- f )
.dword _IF ; ( f -- )
.dword done
.dword PARSE_WORD ; ( -- c-addr u )
.dword QDUP ; ( c-addr u -- c-addr u | c-addr u u )
.dword _IF ; ( c-addr u | c-addr u u | c-addr | c-addr u )
.dword null
.dword TWODUP ; ( c-addr u -- c-addr u c-addr u )
.dword SEARCH_ALL ; ( c-addr u c-addr u - c-addr u xt|0 )
.dword QDUP ; ( c-addr u xt|0 -- c-addr u 0 | c-addr u xt xt )
.dword _IF ; ( c-addr u 0 | c-addr u xt xt -- c-addr u | c-addr u xt )
.dword trynum ; if xt = 0
.dword DROP ; drop flag
2NIP not the same as other Forths, rename and make headerless
2020-01-08 20:25:46 +00:00
.dword NIPTWO ; ( c-addr u xt -- xt )
initial full commit
2019-07-01 17:33:44 +00:00
.dword CONLYQ ; compile-only? (leaves xt on stack
.dword _IFFALSE
.dword conly
.dword _SMART ; no, see if we should compile or execute
.dword exec ; if interpreting
chkimm: .dword IMMEDQ ; compiling, immediate? (leaves xt on stack)
.dword _IFFALSE
.dword exec ; yes, go do it
NLIT COMPILECOMMA
exec: .dword EXECUTE
JUMP loop
trynum: .dword TWODUP ; ( c-addr u -- c-addr u c-addr u )
.dword dNUMBER ; ( c-addr u c-addr u -- c-addr u num false | c-addr u true )
.dword _IF
.dword goodnum ; false = good number
.dword SPACE
.dword TYPE
ONLIT '?'
.dword EMIT
NLIT -13
.dword THROW
2NIP not the same as other Forths, rename and make headerless
2020-01-08 20:25:46 +00:00
goodnum: .dword NIPTWO
initial full commit
2019-07-01 17:33:44 +00:00
.dword _SMART
.dword loop ; if interpreting
.dword LITERAL
JUMP loop
conly: .dword _SMART
.dword trytemp ; if interpreting, try temporary def
JUMP chkimm ; otherwise check immediacy
trytemp: .dword TEMPDQ ; has flag for starting temp def
.dword _IFFALSE
.dword dotemp ; true, so start temporary def
.dword DROP ; otherwise bad state, drop XT
NLIT -14 ; and throw exception
.dword THROW
null: .dword DROP
done: EXIT
; now we gotta do some juggling stack is ( xt )
dotemp: .dword PtoR ; ( xt -- ) ( R: -- xt )
.dword dTEMPCOLON ; start temporary colon definition
.dword RtoP ; ( -- xt ) ( R: xt -- )
JUMP chkimm ; most or all of these should also be immediate...
eword
; ( -- xn...x1 n ) save current source input state
dword SAVEINPUT,"SAVE-INPUT"
ENTER
.dword SOURCE ; address and length of current input
.dword PIN
.dword FETCH ; position in buffer
.dword SOURCEID
ONLIT 4 ; that was 4 things
EXIT
eword
; ( xn...x1 n f1 -- f2 ) restore current source input state, including source ID if f1 is true
dword dRESTOREINPUT,"$RESTORE-INPUT"
ENTER
.dword SWAP ; ( ... addr len ptr srcid f 4 )
ONLIT 4 ; ( ... addr len ptr srcid f 4 4 ) sanity check
.dword EQUAL ; ( ... addr len ptr srcid f1 f2 )
.dword _IF ; ( ... addr len ptr srcid f )
.dword bad
.dword _IF ; ( ... addr len ptr srcid )
.dword nosrcid
.dword dSOURCEID ; ( ... addr len ptr srcid var )
.dword STORE ; ( ... addr len ptr )
JUMP :+
nosrcid: .dword SOURCEID ; ( ... addr len ptr srcid srcid' )
.dword EQUAL ; ( ... addr len ptr f )
.dword _IF ; ( ... addr len ptr )
.dword bad ; can't change sources
: .dword PIN ; otherwise restore all the things
.dword STORE
.dword NIN
.dword STORE
.dword dCIB
.dword STORE
.dword TRUE
EXIT
bad: ONLIT -12
.dword THROW
EXIT
eword
; ( xn...x1 n -- f ) restore current source input state, source ID must match current
dword RESTOREINPUT,"RESTORE-INPUT"
ENTER
.dword FALSE
.dword dRESTOREINPUT
EXIT
eword
; H: ( xxn...xx1 c-addr u -- yxn...yx1 ) interpret text in c-addr u
dword EVALUATE,"EVALUATE"
ENTER
.dword SAVEINPUT
.dword NPtoR ; throw it all on the return stack
.dword PtoR ; along with the count
ONLIT -1
.dword dSOURCEID ; standard requires source-id to be -1 during EVALUATE
.dword STORE
ONLIT 0 ; input to first character
.dword PIN
.dword STORE
.dword NIN ; string length to #IN
.dword STORE
.dword dCIB ; current input buffer to string address
.dword STORE
ONLIT INTERPRET
.dword CATCH ; we do this so that we can restore input if exception
.dword RtoP ; now put the input back to where we were
.dword NRtoP
.dword TRUE
.dword dRESTOREINPUT ; restore the input spec, including source ID
.dword DROP
.dword THROW ; finally, re-throw any exception
EXIT
eword
; H: synonym for EVALUATE
dword EVAL,"EVAL"
bra EVALUATE::code
eword
; ( "n"<> n ) parse number n, compile as literal if compiling
hword nNUM,"#NUM"
ENTER
.dword PARSE_WORD
.dword DUP
.dword _IF
.dword empty
.dword dNUMBER
.dword _IFFALSE
.dword bad
.dword _SMART
.dword interp
.dword LITERAL
interp: EXIT
empty: .dword TWODROP
bad: ONLIT -24
.dword THROW
eword
; H: ( "#"<> -- n | -- ) parse following number as decimal, compile as literal if compiling
dword DNUM,"D#",F_IMMED
ENTER
ONLIT 10
tmpbase: ONLIT nNUM
.dword SWAP
.dword TMPBASE
EXIT
eword
; H: ( "#"<> -- n | -- ) parse following number as hex, compile as literal if compiling
dword HNUM,"H#",F_IMMED
ENTER
ONLIT 16
JUMP DNUM::tmpbase
eword
; H: ( "#"<> -- n | --) parse following number as octal, compile as literal if compiling
dword ONUM,"O#",F_IMMED
ENTER
ONLIT 8
JUMP DNUM::tmpbase
eword
; Forget is a stupidly dangerous word when you have multiple wordlists, noname words,
; and such. Not recommended to use except for the most recently-defined few words in
; the current wordlist.
; first we will scan the dictionary to see if the word to be forgotten is below
; the protection bit, and if it is found before we match the XT, we don't allow the
; forget
minor help text updates
2020-01-06 20:30:46 +00:00
; H: ( xt -- ) forget word referenced by xt and subsequent words
initial full commit
2019-07-01 17:33:44 +00:00
dword dFORGET,"$FORGET"
ENTER
.dword DUP ; ( xt -- xt xt' )
.dword QDUP
.dword _IF
.dword cant
.dword rLINK ; ( xt xt' -- xt link )
.dword _IF ; ( xt link -- xt )
.dword cant
.dword LAST ; ( xt -- xt a-addr )
lp: .dword DUP ; ( xt a-addr -- xt a-addr a-addr' )
.dword drXT ; ( xt a-addr a-addr' -- xt a-addr xt2 )
.dword DUP ; ( xt a-addr xt2 -- xt a-addr xt2 xt2' )
.dword FETCH ; ( xt a-addr xt2 xt2' -- xt a-addr xt2 flags )
ONLIT F_PROT ; ( xt a-addr xt2 flags -- xt a-addr xt2 flags F_PROT )
.dword LAND ; ( xt a-addr xt2 flags F_PROT -- xt a-addr xt2 f )
.dword _IFFALSE ; ( xt a-addr xt2 f -- xt a-addr xt2 )
.dword prot
.dword SWAP ; ( ... xt xt2 a-addr )
.dword PtoR ; ( ... xt xt2 ) ( R: -- a-addr )
.dword OVER ; ( ... xt xt2 xt' )
.dword EQUAL ; ( ... xt f )
.dword _IFFALSE ; ( ... xt )
.dword amnesia
.dword RtoP ; ( xt -- xt a-addr ) ( R: a-addr -- )
.dword FETCH ; ( xt a-addr -- xt a-addr2 )
.dword QDUP
.dword _IF
.dword cant
JUMP lp
amnesia: .dword RDROP ; ( R: a-addr -- )
.dword rLINK
.dword DUP
.dword toHERE
.dword FETCH
.dword GET_CURRENT
.dword STORE
EXIT
prot: .dword TWODROP ; ( xt a-addr xt2 -- xt )
cant: SLIT "Can't forget " ; ( xt -- xt str len )
.dword TYPE ; ( xt str len -- xt )
.dword rNAME ; ( xt -- str len )
.dword TYPE ; ( str len -- )
EXIT
eword
; H: ( "name"<> -- ) attempt to forget name and subsequent definitions in compiler
minor help text updates
2020-01-06 20:30:46 +00:00
; H: word list. This may have unintended consequences if things like wordlists and
; H: such were defined after name.
initial full commit
2019-07-01 17:33:44 +00:00
dword FORGET,"FORGET"
ENTER
.dword PARSEFIND
.dword dFORGET
EXIT
eword
; remove any incomplete or temporary definitions
; executed by QUIT to clean up after an exception results in a return to the outer
; interpreter.
hword dPATCH,"$PATCH"
ENTER
.dword STATEI ; ensure interpretation state
.dword dTMPDEF
.dword FETCH
.dword _IF ; in the middle of a temporary definition?
.dword :+ ; no, see if we were doing a normal def
.dword dSAVEHERE ; ( -- a-addr ) restore HERE
.dword FETCH ; ( a-addr -- c-addr )
.dword toHERE ; ( c-addr -- )
ONLIT 0 ; ( -- 0 )
.dword dTMPDEF ; ( 0 -- 0 a-addr )
.dword DUP ; ( 0 a-addr -- 0 a-addr a-addr' )
.dword FETCH ; ( 0 a-addr a-addr' -- 0 a-addr c-addr )
ONLIT max_tempdef ; ( ... 0 a-addr c-addr u )
.dword FREE ; ( ... 0 a-addr )
.dword STORE ; ( 0 a-addr -- )
: .dword OLDHERE ; is OLDHERE not 0?
.dword _IF
.dword nopatch ; is zero, no need to patch
.dword LAST ; it is! check smudge bit of last definition
.dword drXT
.dword CFETCH
ONLIT F_SMUDG
.dword LAND
.dword _IF ; is smudge bit set?
.dword nopatch ; nope, no need to patch
.dword LAST ; yes, start fixup by setting LAST to the value at [LAST]
.dword FETCH ; LAST @
.dword GET_CURRENT ; CURRENT
.dword STORE ; !
.dword OLDHERE ; fix HERE
.dword toHERE ; ->HERE
ONLIT 0 ; clear OLDHERE
.dword dOLDHERE ; $OLDHERE
.dword STORE ; !
nopatch: EXIT
eword
; H: ( -- ) ( R: ... -- ) enter outer interpreter loop, aborting any execution
dword QUIT,"QUIT"
lda RSTK_TOP ; reset return stack pointer
tcs
ENTER
.dword dPATCH ; fix top of dictionary/remove temp defs
.dword CR
source0: .dword SETKBD ; set keyboard as input source
lp: ONLIT 0 ; clear #LINE since we are at input prompt
.dword NLINE
.dword STORE
.dword REFILL ; fill input buffer
.dword _IF ; get anything?
.dword source0 ; no, reset to keyboard and get more
.dword INTERPRET ; otherwise, interpret
.dword dSTATUS ; display status
JUMP lp
eword
__doquit = QUIT::code
PLATFORM_INCLUDE "platform-words.s" ; Platform additional dictionary words
; Leave these toward the top
; H: ( -- -1 )
dword MINUSONE,"-1"
lda #$FFFF
tay
PUSHNEXT
eword
; H: ( -- 3 )
dword THREE,"3"
FCONSTANT 3
eword
; H: ( -- 2 )
dword TWO,"2"
FCONSTANT 2
eword
; H: ( -- 1 )
dword ONE,"1"
lda #$0000
tay
iny
PUSHNEXT
eword
; H: ( -- 0 )
dword ZERO,"0"
lda #$0000
tay
PUSHNEXT
eword
dend
Reference in New Issue Copy Permalink