From f7307a5ea0a0f3d835b5ba36ebd6d31529c6cf51 Mon Sep 17 00:00:00 2001 From: mgcaret Date: Wed, 12 Dec 2018 08:58:23 -0800 Subject: [PATCH] dxforth: experimental Forth interpreter as davex external command, see dxforth.txt --- Makefile | 2 +- dxforth.s | 5313 +++++++++++++++++++++++++++++++++++++++++++++++++++ dxforth.txt | 467 +++++ 3 files changed, 5781 insertions(+), 1 deletion(-) create mode 100644 dxforth.s create mode 100644 dxforth.txt diff --git a/Makefile b/Makefile index e4392aa..03c65dd 100755 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ BOOTDSK=~/vii_hd.2mg CA65=ca65 LD65=utils/auto_origin.sh ld65 GENHELP=utils/gen_help.sh -MG_CMDS=at.info.p8c at.zones.p8c afp.userprefix.p8c afp.sessions.p8c alias.p8c at.boot.p8c deschw.p8c dmem.p8c nbp.lookup.p8c tardis.p8c nbp.parse.p8c iie.card.p8c idemu.p8c mig.insp.p8c fastchip.p8c afp.timezone.p8c setyear.p8c diskinfo.p8c +MG_CMDS=at.info.p8c at.zones.p8c afp.userprefix.p8c afp.sessions.p8c alias.p8c at.boot.p8c deschw.p8c dmem.p8c nbp.lookup.p8c tardis.p8c nbp.parse.p8c iie.card.p8c idemu.p8c mig.insp.p8c fastchip.p8c afp.timezone.p8c setyear.p8c diskinfo.p8c dxforth.p8c .PHONY: all all: shk ; diff --git a/dxforth.s b/dxforth.s new file mode 100644 index 0000000..2e8d684 --- /dev/null +++ b/dxforth.s @@ -0,0 +1,5313 @@ +; %help +; Davex Forth interpeter. +; +; syntax: dxforth +; +; This is a Forth system implementing the Forth 2012 Core Word Set +; a subset of the Core Extensions word set, the Exception word set, +; and select words from other word sets. +; +; Additionally, words supporting Davex and ProDOS are provided. +; +; See the full documentation (not written yet) for complete information. +; %hend + +; This is a byte-addressed, direct-threaded, 16-bit Forth. The stack +; can't be on the zero page due to Davex only giving us 32 bytes there. +; so it's a bit slower than some Forths due to that. + +; PSP = X register +; RSP = 6502 stack +; IP = self-modified in fetch_IP +; DLAST = xczpage+0,1 - last dictionary word defined, HBYTE=0, none +; CHERE = xczpage+2,3 - next address to be compiled +; WR = xczpage+4,5 - working register +; XR = xczpage+6,7 - working register +; YR = xczpage+8,9 - working register +; ZR = xczpage+10,11 - working register +; ZSTATE = xczpage+12,13 - compilation state +; ZBASE = xczpage+14,15 - system number base +; ZACC = xczpage+16..19 - mixed-precision multiply accumulator +; SPTMP = xcpage+20,21 - place to save X register for operations that use it +; HIMEM = SPTMP+22,23 - highest available memory address+1 +; RSSVE = xczpage+24,25 - saves the 6502 stack pointer upon system entry +; IHERE = xczpage+26,27 - start of user dictionary space +; INBUF = xczpage+28,29 - location of input buffer +; TRADR = xczpage+$1E - trace address (when assembled with tracing enabled) + +; ***** Options & Debugging ***** +.define TRACE 0 +.define TRACE_WORDS 0 + +; ***** Firmware ***** +COut = $fded +COut1 = $fdf0 +TabV = $fb5b +PrByte = $fdda +Home = $fc58 +VTab = $fc22 +;KeyIn = $fd1b ; do not use for davex +PrntAX = $f941 + +; ***** Zero Page ***** + +CH = $24 +CV = $25 + +.globalzp xczpage ; davex should do this +DLAST = xczpage +CHERE = DLAST+2 +WR = CHERE+2 ; working register +XR = WR+2 ; second working reg +YR = XR+2 ; for saving Y register, usually +ZR = YR+2 ; used for searching dict +ZSTATE = ZR+2 ; nonzero = compiling +ZBASE = ZSTATE+2 +ZACC = ZBASE+2 ; 4 bytes +ZACC1 = ZACC +ZACC2 = ZACC1+2 +SPTMP = ZACC+4 ; for primitives to save data stack ptr for certain ops +HIMEM = SPTMP+2 ; maybe for memory management + +RSSAV = xczpage+$18 ; for stuff we don't re-init +IHERE = RSSAV+2 ; start of user-defined dictionary words +INBUF = IHERE+2 ; location of input buffer + +TRADR = xczpage+$1E + +.assert (HIMEM+2)<=RSSAV,error,"fix zpage stuff!" + +; ***** Constants ***** + +.define PSTK_SZ $80 ; size of parameter stack, some optimizations when $80 +PSTK = $AF00 ; covered by the reserve +PSTKL = PSTK +PSTKH = PSTK+PSTK_SZ + +.define PAD_SIZE 128 ; (for reference, not directly used yet) + ; minimum required by standard is 84 +.define WORD_SIZE 35 ; minimum required by standard is 33, but + ; the pictured numeric output words share + ; it and is required to be + ; 2*(cell size in bits=1)+2 = 34 bytes, plus + ; we want a count byte at the beginning + +; compiler constants +.define opJSR $20 ; JSR opcode +.define opJMP $4C ; JMP opcode +.define opRTS $60 ; RTS opcode +.define opNOP $EA ; NOP opcode + +; flags for words +.define F_IMMED %01000000 ; immediate +.define F_CONLY %00100000 ; compile-only +.define F_SMUDG %00010000 ; smudged, invisible in search + +; Control chars +AFF = $0C +ACR = $0D + +; Non-keyboard/eval source IDs (high byte) +.define SRC_REDIR $FE ; Input redirected +.define SRC_ARG $FD ; File given on command line + +; Misc +P8_ER_RNG = $FE ; range of P8 errors for exception numbers + +.macro ENTER + jsr enter +.endmacro + +.macro EXIT + .addr exit_next +.endmacro + +.macro CODE + .addr exit_code +.endmacro + +.macro NEXT + jmp next +.endmacro + +; optimization for the common case where +; a native word would end with jsr pushay followed by NEXT +.macro PUSHNEXT + jmp next::fast_num +.endmacro + +.macro RUN + jmp next::run +.endmacro + +.macro NLIT num + .if num & $FF00 + .word LIT::xt + .endif + .byte <(num) ; can't do .word because ca65 won't allow negative + .byte >(num) +.endmacro + +.macro SLIT str + .local target,addr + .addr _JUMP + .addr target +addr: + .byte str +target: + NLIT addr + NLIT .strlen(str) +.endmacro + +.macro CSLIT str + .local target,addr + .addr _JUMP::xt + .addr target +addr: + .byte .strlen(str) + .byte str +target: + NLIT addr +.endmacro + +; dictionary macros + +; Dictionary format: +; Bytes Purpose +; 2 Link to previous +; 1 flags & Name length, high bit always set +; n Name (low ASCII) +; m Code field (direct threaded, CFA is eliminated) +; ... next entry or HERE + +; +print_dict .set 1 +; +.macro dstart + __dstart = 0 + .define l_dword __dstart +.endmacro + +; define a headerless word +; fname is there so that a word can be switched back and +; forth between a headerless and normal. Flags are irrelevant +; because headerless words can't be used by the user. +.macro hword dname,fname,flags + .ifnblank flags + .out "Warning: flags used on headerless word" + .endif + .ifdef c_dword + .error .sprintf("%s definition not closed",.string(c_dword)) + .endif + .ifdef c_hword + .error .sprintf("%s definition not closed",.string(c_hword)) + .endif + .if print_dict + .if .const(*) + .out .concat(fname, .sprintf(" (headerless) starts at $%x", *)) + .endif + .endif + .define c_hword dname + .proc dname + xt: + .if TRACE_WORDS + trace fname + .endif +.endmacro + +.macro dword dname,fname,flags + .ifdef c_dword + .error .sprintf("%s definition not closed",.string(c_dword)) + .endif + .ifdef c_hword + .error .sprintf("%s definition not closed",.string(c_hword)) + .endif + .if print_dict + .if .const(*) + .out .concat(fname, .sprintf(" starts at $%x", *)) + .endif + .endif + .define c_dword dname + .proc dname + .addr l_dword + .ifblank flags + .byte $80+.strlen(fname) + .else + .byte ($80|flags)+.strlen(fname) + .endif + .byte fname + xt: + .if TRACE_WORDS + jsr trace_word + .endif + ;.if print_dict + ; .out .concat(fname, .sprintf(" entry at $%x", xt)) + ;.endif +.endmacro + +.macro dwordq dname,fname,flags + .charmap $27,$22 ; temporarily map ' -> " + dword dname,fname,flags + .charmap $27,$27 ; undo mapping +.endmacro + +.macro dchain dname + .ifdef l_dword + .undefine l_dword + .endif + .define l_dword dname +.endmacro + +.macro eword + .endproc + .ifdef c_dword + dchain c_dword + .undefine c_dword + .endif + .ifdef c_hword + .undefine c_hword + .endif +.endmacro + +.macro dconst dname,fname,value,flags + dword dname,fname,flags + ldy #value + PUSHNEXT + eword +.endmacro + +.macro hconst dname,fname,value,flags + hword dname,fname,flags + ldy #<(value) + lda #>(value) + PUSHNEXT + eword +.endmacro + +.macro dvar dname,fname,value,flags + dword dname,fname,flags + jsr pushda + val: .word value + eword +.endmacro + +.macro hvar dname,fname,value,flags + hword dname,fname,flags + jsr pushda + val: .word value + eword +.endmacro + +.macro dvalue dname,fname,value,flags + dword dname,fname,flags + jsr pushconst + val: .word value + eword +.endmacro + +.macro hvalue dname,fname,value,flags + hword dname,fname,flags + jsr pushconst + val: .word value + eword +.endmacro + + +.macro dend + ELAST = l_dword +.endmacro + +.macro trace name + .if TRACE_WORDS + jsr tr_save_regs + jsr xmess + .byte '{',name,'}',$00 + jsr tr_rest_regs + .endif +.endmacro + +.p02 +.include "davex-mg.inc" + + ;DX_start dx_mg_auto_origin,$100 ; load address & top reserve + DX_start $8E00,$100 ; load address & top reserve for stack +version: DX_info $01,$12,dx_cc_any,$00 + DX_ptab + DX_parm 0,t_path + DX_end_ptab + DX_desc "Forth interpreter." + DX_main + ; first init the immutables + tsx + stx RSSAV ; save 6502 stack ptr + ldx #mli_read + jsr xmmgr ; get # free pages + cmp #$03 ; need at least 3 pages... + bcc nomem + tax ; work around mmgr bug + dex + txa + ldx #mli_open + jsr xmmgr + bcs nomem + sta INBUF+1 + sta IHERE+1 + inc IHERE+1 ; make room for input buffer + lda #$00 + sta SOURCE_ID + sta SOURCE_ID+1 + jsr xgetparm_n ; see if file given + sta WR+1 + sty WR + ldy #$00 + lda (WR),y + beq :+ + lda #SRC_ARG + sta SOURCE_ID+1 ; flag initial source ID +: ldx #$00 ; init stack ptr + stx INBUF + stx IHERE + jmp _cold ; now cold-start the interpreter +nomem: jsr xmess + .byte "Not enough memory!",$0D,$00 + jmp xerr + +.if TRACE +.proc _dtrace + txa + pha + lda TRADR+1 + jsr PrByte + lda TRADR + jsr PrByte + pla + tax + rts +.endproc +.endif + +.if TRACE_WORDS +.proc trace_word + jsr tr_save_regs + tsx + pla + tay + pla + txs + sta TRADR+1 + sty TRADR + ; TRADR now points at the last byte of the JSR + jsr dec_tradr ; to middle byte + jsr dec_tradr ; to first byte +: jsr dec_tradr ; last byte of name, or flags+len if anon + bpl :- + and #$0F + beq anon ; anonymous + sta check + lda #'{' + jsr _emit + ldy #$00 +: iny + lda (TRADR),y + cmp #' ' + bcc nono + jsr _emit +nono: cpy #$00 ; self-modified +check = * - 1 + bcc :- + lda #'}' + jsr _emit + jsr tr_rest_regs + rts +anon: jsr xmess + .byte "{noname}",$00 + ; fall-through to tr_rest_regs +.endproc + +.proc tr_rest_regs + lda #$00 +psave = * - 1 + pha + lda #$00 +asave = * - 1 + ldx #$00 +xsave = * - 1 + ldy #$00 +ysave = * - 1 + plp + rts +.endproc + +.proc tr_save_regs + php + sta tr_rest_regs::asave + stx tr_rest_regs::xsave + sty tr_rest_regs::ysave + pla + sta tr_rest_regs::psave + rts +.endproc + +.proc dec_tradr + lda TRADR + bne :+ + dec TRADR+1 +: dec TRADR + ldy #$00 + lda (TRADR),y + rts +.endproc +.endif + +; inner interpreter entry +; pops caller from 6502 stack and initializes IP with it +; saving previous IP on 6502 stack. +.proc enter +.if TRACE + txa + pha + jsr xmess + .byte $8D,"[ENTER]",$00 + jsr xcheck_wait + pla + tax +.endif + lda IP + sta WR + lda IP+1 + sta WR+1 + pla + sta IP + pla + sta IP+1 + lda WR+1 + pha + lda WR + pha + ; fall-through +.endproc + +; fetch and execute next instruction +.proc next + jsr fetch_IP ; fetch low byte + tay + jsr fetch_IP +.if TRACE + beq fast_num1 +.else + beq fast_num +.endif +run: sta target+1 + sty target +.if TRACE + sta TRADR+1 + sty TRADR + txa + pha + lda #'>' + jsr _emit + jsr _dtrace + pla + tax +.endif + jmp * ; self-modified, dispatch xt +target = * - 2 +.if TRACE +fast_num1: + sta TRADR+1 + sty TRADR + txa + pha + lda #'^' + jsr _emit + pla + tax + lda TRADR+1 + ldy TRADR +.endif +fast_num: + jsr pushay ; throw on stack + jmp next ; and immediately do next insn +.endproc + +.proc fetch_IP + inc IP + bne :+ + inc IP+1 +: +.if TRACE + lda IP + sta TRADR + lda IP+1 + sta TRADR+1 + txa + pha + lda #':' + jsr _emit + jsr _dtrace + pla + tax +.endif + lda * ; self-modified +IP = * - 2 + rts +.endproc +IP = fetch_IP::IP + +; exit thread. restore previous IP +; and resume execution at Forth IP +.proc exit_next + .if TRACE + txa + pha + jsr xmess + .byte "[EXIT]",$8D,$00 + jsr xcheck_wait + pla + tax + .endif + pla ; and restore IP of caller's caller + sta IP + pla + sta IP+1 + NEXT +.endproc + +; exit thread, restore previous IP +; and resume 6502 after last executed IP +.proc exit_code + ldy IP ; save IP + sty YR + lda IP+1 + sta YR+1 +.if TRACE + sta TRADR+1 + sty TRADR + txa + pha + jsr xmess + .byte ">CODE:",$00 + jsr _dtrace + pla + tax +.endif + pla ; restore previous IP + sta IP + pla + sta IP+1 + lda YR+1 ; old IP on 6502 stack + pha + lda YR + pha + rts ; rts resumes execution at IP+1 +.endproc + +; ***** stack primitives ***** + +.proc peekay + jsr popay + inx + rts +.endproc + +; flags reflect the high byte of the popped word +.proc popay + dex + bmi stku_err + ldy PSTKL,x + lda PSTKH,x +.if TRACE + sta TRADR+1 + sty TRADR + txa + pha + lda #'/' + jsr _emit + jsr _dtrace + pla + tax + ldy PSTKL,x + lda PSTKH,x +.endif + rts +.endproc + +.proc popwr + jsr popay + sta WR+1 + sty WR + rts +.endproc + +.proc popxr + jsr popay + sta XR+1 + sty XR + rts +.endproc + +; stack pop routines for davex routines +; ( d -- ) -> A(high) XY(low) = d truncated to 24 bits +; X will be saved in SPTMP +.proc popaxy + jsr popay ; high cell + sty YR+1 ; to by A later + jsr popay ; low cell + stx SPTMP + tax + lda YR+1 + rts +.endproc + +.proc stku_err + ldx #$00 + ldy #<-4 + lda #>-4 + jmp _throway +.endproc + +.proc stko_err + ldx #PSTK_SZ-8 ; leave enough room for ops + ldy #<-3 + lda #>-3 + jmp _throway +.endproc + +; push AY onto stack, preserves contents of AY +.proc pushay +.if TRACE + sta TRADR+1 + sty TRADR +.endif + pha + sta PSTKH,x + tya + sta PSTKL,x + pla + inx +.if PSTK_SZ=$80 + bmi stko_err +.else + cpx #PSTK_SZ + bcs stko_err +.endif +.if TRACE + pha + lda #'#' + jsr _emit ; these must preserve regs 'cept A + jsr _dtrace + pla +.endif + rts +.endproc + +; preserves AY +.proc pusha +.if TRACE + sta TRADR +.endif + pha + sta PSTKL,x + lda #$00 + sta PSTKH,x + pla + inx +.if PSTK_SZ=$80 + bmi stko_err +.else + cpx #PSTK_SZ + bcs stko_err +.endif +.if TRACE + pha + lda #$00 + sta TRADR+1 + lda #'#' + jsr _emit + jsr _dtrace + pla +.endif + rts +.endproc + +; ***** Interpretation Helpers ***** + +; push word data address +; this is the default routine used by CREATE +; call via JSR, pops return stack entry, pushes data addr onto stack, and +; exits via next +.proc pushda + pla ; get low byte + clc + adc #$01 + tay + pla + adc #$00 ; in case page crossed + PUSHNEXT +.endproc + +; push constant +; pushes the word following the JSR onto the stack +; and exits via next, this is also used by VALUE +.proc pushconst + pla ; low byte + clc + adc #$01 ; account for RTS PC-1 + sta WR + pla + adc #$00 + sta WR+1 + ldy #$01 + lda (WR),y + pha + dey + lda (WR),y + tay + pla + PUSHNEXT +.endproc + +; ***** Compilation Helpers ***** + +.proc cworday + pha + tya + ldy #$00 + sta (CHERE),y + iny + pla + sta (CHERE),y + jsr inchere + ; fall-through +.endproc + +.proc inchere + inc CHERE + bne :+ + inc CHERE+1 +: rts +.endproc + +.proc cbytea + ldy #$00 + sta (CHERE),y + jmp inchere +.endproc + +; ***** Math Library ***** +; save X before calling any of these +; use YR and ZR for the operands, ZACC for the results + +; ZACC(32)=ZR(16)*YR(16) +; adapted from https://www.llx.com/~nparker/a2/mult.html +.proc _umult + lda #0 + sta ZACC+2 + ldx #16 +l1: lsr YR+1 + ror YR + bcc l2 + tay + clc + lda ZR + adc ZACC+2 + sta ZACC+2 + tya + adc ZR+1 +l2: ror + ror ZACC+2 + ror ZACC+1 + ror ZACC + dex + bne l1 + sta ZACC+3 + rts +.endproc + +; ZR rem ZACC1=ZR/YR +; ibid. +.proc _udiv + lda #0 + sta ZACC1 + sta ZACC1+1 + ldx #16 +l1: asl ZR + rol ZR+1 + rol ZACC1 + rol ZACC1+1 + lda ZACC1 + sec + sbc YR + tay + lda ZACC1+1 + sbc YR+1 + bcc l2 + sta ZACC1+1 + sty ZACC1 + inc ZR +l2: dex + bne l1 + rts +.endproc + +; ZACC(16) rem ZR(16)=ZR(32)/YR(16) +; adapted from Garth Wilson's routines +; N=0:YR 1:YR+1 2:ZR 3:ZR+1 4:ZACC 5:ZACC+1 6:ZACC+2 7:ZACC+3 +.proc _umdiv + sec + lda ZR + sbc YR + lda ZR+1 + sbc YR+1 + bcc :+ ; no overflow + ldy #<-11 + lda #>-11 + jmp _throway ; result out of range +: ldx #$11 +loop: rol ZACC + rol ZACC+1 + dex + bne :+ + rts +: rol ZR + rol ZR+1 + lda #$00 + sta ZACC+3 ; carry + rol ZACC+3 + sec + lda ZR + sbc YR + sta ZACC+2 + lda ZR+1 + sbc YR+1 + tay + lda ZACC+3 + sbc #$0 + bcc loop + lda ZACC+2 + sta ZR + sty ZR+1 + bcs loop +.endproc + +; ***** DICTIONARY ***** + +dstart + +; push a compiled literal at IP on the stack +; headerless native +hword LIT,"LIT" + jsr fetch_IP + tay + jsr fetch_IP + PUSHNEXT +eword + +; directly compile a cell literal from IP to (HERE) +hword COMP_LIT,"COMP_LIT" + jsr fetch_IP + tay + jsr fetch_IP + jsr cworday + NEXT +eword + +; directly compile a char literal from IP to (HERE) +hword COMP_CLIT,"COMP_CLIT" + jsr fetch_IP + jsr cbytea + NEXT +eword + +; Programming-Tools 15.6.2.0830 +; quit intepreter ( -- ) +dword BYE,"BYE" + tya + ldx RSSAV + txs + tay + lda #mli_close + jsr xmmgr ; free all mem + rts +eword + +; backing value for SOURCE-ID +hvar dSOURCEID,"$SOURCE-ID",0 +SOURCE_ID = dSOURCEID::val + +; backing values for string buffers +hconst SBUF1,"SBUF1",filebuff3 +hconst SBUF2,"SBUF2",filebuff3+256 +hvar CSBUF,"CSBUF",filebuff3 + +; non-standard +; coldstart interpreter ( * -- ) +; resets to built-in dictionary, clear stack, etc. +dword COLD,"COLD" + jmp _cold +eword + +; Core 6.1.2250 +; really a variable, but address is constant +dconst STATE,"STATE",ZSTATE + +; non-standard +hconst DMEMTOP,"$MEMTOP",X_DX_LOAD + +; non-standard +; really a variable, but address is constant +hconst DHIMEM,"$HIMEM",HIMEM + +.proc _emit + ora #$80 + jmp COut ; it must preserve al registers +.endproc + +; Core 6.1.1320 +dword EMIT,"EMIT" + jsr popay + tya + jsr _emit + NEXT +eword + +; ( c-addr u -- ) +; Consume c-addr and u, applying routine at (ZR), inited from AY, +; to every char of the string. +; When (ZR) is called, next char is in A. (ZR) may trash +; any registers except X, and must not touch WR and XR +; when it's called, Y=0 and XR=address of string +.proc string_op_ay + sta ZR+1 + sty ZR +op: jsr popwr ; length into WR + jsr popxr ; address into XR + lda WR ; now calculate ending pos into WR + clc + adc XR + sta WR + lda WR+1 + adc XR+1 + sta WR+1 +lp: lda WR + cmp XR + bne :+ + lda WR+1 + cmp XR+1 + bne :+ + rts +: ldy #$00 ; here in case (XR) trashes it + lda (XR),y + jsr docall + inc XR + bne :+ + inc XR+1 +: jmp lp +docall: jmp (ZR) +.endproc +string_op = string_op_ay::op ; user sets ZR instead + +; Core 6.1.2310 +dword TYPE,"TYPE" + ldy #<_emit + lda #>_emit + jsr string_op_ay + NEXT +eword + +; Core 6.1.1370 +; ( xt -- * ) +dword EXECUTE,"EXECUTE" + jsr popay + RUN +eword + +; headlerless word to implement branches +hword _JUMP,"_JUMP" +jump2: jsr fetch_IP + tay + jsr fetch_IP + ; we need to be at one less than the given target + cpy #$00 + bne :+ + sec + sbc #$01 +: dey +go: sta IP+1 + sty IP + NEXT +eword + + +; headlerless word to implement control flow +hword _SKIP,"_SKIP" +skip2: jsr fetch_IP + jsr fetch_IP + NEXT +eword + +; headerless word to implement state-smartness +; if interpreting, jumps, if compiling, skips +hword _SMART,"_SMART" + lda ZSTATE + ora ZSTATE+1 + beq _JUMP::xt + bne _SKIP::xt +eword + +; headlerless word to implement control flow +hword _SKIP2,"_SKIP2" + jsr fetch_IP + jsr fetch_IP + jmp _SKIP::skip2 +eword + +.if 0 ; may not need this +; headlerless word to implement control flow +hword _SKIPJUMP,"SKIPJUMP" + jsr fetch_IP + jsr fetch_IP + jmp _JUMP::jump2 +eword +.endif + +; Core 6.1.0150 +; ( n -- ) compile word into dictionary +dword COMMA,"," + jsr popay + jsr cworday + NEXT +eword + +; Core 6.1.0860 +; ( c -- ) compile char into dictionary +dword CCOMMA,"C," + jsr popay + tya + jsr cbytea + NEXT +eword + +; helper +.proc wrplus2 + lda WR + clc + adc #$02 + sta WR + lda WR+1 + adc #$00 + sta WR+1 + rts +.endproc + +; Core 6.1.0650 +; ( adr -- n ) get number n from adr +dword FETCH,"@" + jsr popwr +fetch2: jsr fetchay + PUSHNEXT +fetchay: ldy #$01 ; need to re-use + lda (WR),y + pha + dey + lda (WR),y + tay + pla + rts +eword + +; Core 6.1.0350 +; ( addr -- x1 ) - store x2,x1 at addr,addr+cell +dword TWOFETCH,"2@" + jsr popwr + jsr FETCH::fetchay + jsr pushay + jsr wrplus2 + jmp FETCH::fetch2 +eword + +; Core 6.1.0870 +; ( adr - c ) get char c from adr +dword CFETCH,"C@" + jsr popwr + ldy #$00 + lda (WR),y + jsr pusha + NEXT +eword + +; Core 6.1.0010 +; ( x addr ) - store n at addr +dword STORE,"!" + jsr popwr ; pop addr into WR +store2: jsr popay ; pop n + jsr storeay ; need to re-use + NEXT +storeay: pha ; save high byte of n + tya ; store low byte first + ldy #$00 + sta (WR),y + pla ; get high byte back + iny + sta (WR),y + rts +eword + +; Core 6.1.0310 +; ( x1 x2 addr ) - store x2,x1 at addr,addr+cell +dword TWOSTORE,"2!" + jsr popwr + jsr popay + jsr STORE::storeay + jsr wrplus2 + jmp STORE::store2 +eword + +; Core 6.1.0010 +; ( c adr ) - store char c at addr +dword CSTORE,"C!" + jsr popwr + jsr popay + tya + ldy #$00 + sta (WR),y + NEXT +eword + +; Core 6.1.1290 +dword DUP,"DUP" + jsr peekay + PUSHNEXT +eword + +; Core 6.1.0630 +dword QDUP,"?DUP" + jsr peekay + cmp #$00 + bne :+ + cpy #$00 + bne :+ + NEXT +: PUSHNEXT +eword + +; Core 6.1.0580 +dword PtoR,">R" + jsr popay + pha + tya + pha + NEXT +eword + +; Core ext 6.2.0340 +; Must be primitive +dword TWOPtoR,"2>R" + jsr _swap + jsr popay + pha + tya + pha + jmp PtoR::xt +eword + +; Non-standard helper +; ( x1 .. xn n -- n | r: -- xn .. x1 ) +; copy x1-xn to return stack, leave n on param stack, n <= 255 +; must be primitive, note not in the same order as TWOPtoR +hword NPtoR,"N>R" + jsr popay ; get n + sty YR + sty YR+1 ; save n + cpy #$00 ; just in case + beq done +: jsr popay + pha + tya + pha + dec YR + bne :- +done: lda #$00 + ldy YR+1 + PUSHNEXT +eword + + +; Core 6.1.2060 +dword RtoP,"R>" + pla + tay + pla + PUSHNEXT +eword + +; Core ext 6.2.0410 +; must be a primitive +dword TWORtoP,"2R>" + pla + tay + pla + jsr pushay + pla + tay + pla + jsr pushay + jsr _swap + NEXT +eword + +; Non-standard helper +; ( r: -- xn .. x1 | n -- x1 .. xn n | ) +; copy x1-xn to parameter stack, leave n on top of param stack, n <= 255 +; must be primitive, note not in the same order as TWORtoP +hword NRtoP,"N>R" + jsr popay ; get n + sty YR + sty YR+1 ; save n + cpy #$00 ; just in case + beq done +: pla + tay + pla + jsr pushay + dec YR + bne :- +done: lda #$00 + ldy YR+1 + PUSHNEXT +eword + + +; Core 6.1.2070 +dword RCOPY,"R@" + stx SPTMP + tsx + pla + tay + pla + txs + ldx SPTMP + PUSHNEXT +eword + +; Non-standard +.if 0 +dword RSPat,"RSP@" + stx SPTMP + tsx + txa + tay + lda #$01 + ldx SPTMP + PUSHNEXT +eword +.endif + +; non-standard +dword RDROP,"RDROP" + pla + pla + NEXT +eword + +; non-standard helper +hword RPICK,"RPICK" + jsr popay + tya + asl + sta WR + stx SPTMP + tsx + txa + sec ; +1 + adc WR + tax + lda $100,x + tay + lda $101,x + ldx SPTMP + PUSHNEXT +eword + +; headerless helper +; get the 2nd entry from the return stack +hword RPLUCK,"RPLUCK" + pla + sta WR + pla + sta WR+1 + pla + tay + pla + jsr pushay + lda WR+1 + pha + lda WR + pha + NEXT +eword + +; more complicated due to the split stack +.proc _swap + jsr popay + pha + tya + pha + jsr peekay + jsr pushay + dex + dex + pla + tay + pla + jsr pushay + inx + rts +.endproc + +; Core 6.1.2260 +dword SWAP,"SWAP" + jsr _swap + NEXT +eword + +; Core 6.1.1260 +dword DROP,"DROP" + jsr popay + NEXT +eword + +.proc _over + jsr popay + jsr popay + inx ; we know there are 2 values above SP + inx + jsr pushay + rts +.endproc + +; Core 6.1.1990 +dword OVER,"OVER" + jsr _over + NEXT +eword + +; Core ext 6.2.1930 +dword NIP,"NIP" + ENTER + .addr SWAP::xt + .addr DROP::xt + EXIT +eword + +; Core ext 6.2.2300 +dword TUCK,"TUCK" + ENTER + .addr SWAP::xt + .addr OVER::xt + EXIT +eword + +; Core 6.1.0390 +dword TWODUP,"2DUP" + jsr _over + jsr _over + NEXT +eword + +; Core ext 6.2.0415 +; ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) +; must be primitive +dword TWORCOPY,"2R@" + stx SPTMP ; save data stack ptr + tsx ; save 6502 stack ptr + pla ; pop x2 + tay + pla + sta WR+1 ; save x2 in WR + sty WR + pla ; pop x1 + tay + pla + txs ; restore 6502 stack + ldx SPTMP ; restore data stack + jsr pushay ; push x1 + lda WR+1 ; get x2 + ldy WR ; push x2 + PUSHNEXT +eword + + +; Core 6.1.2160 +dword ROT,"ROT" + ENTER + .addr PtoR::xt + .addr SWAP::xt + .addr RtoP::xt + .addr SWAP::xt + EXIT +eword + +; Non-standard +dword NROT,"-ROT" + ENTER + .addr ROT::xt + .addr ROT::xt + EXIT +eword + +; Core 6.1.0430 +dword TWOSWAP,"2SWAP" + ENTER + .addr PtoR::xt + .addr NROT::xt + .addr RtoP::xt + .addr NROT::xt + EXIT +eword + +; Core 6.1.0400 +dword TWOOVER,"2OVER" + ENTER + .addr TWOPtoR::xt + .addr TWODUP::xt + .addr TWORtoP::xt + .addr TWOSWAP::xt + EXIT +eword + +; Core 6.1.0370 +dword TWODROP,"2DROP" + jsr popay + jsr popay + NEXT +eword + +; Core 6.1.0250 +dword ZEROLT,"0<" + jsr popay + and #$80 + beq :+ + lda #$ff +: tay + PUSHNEXT +eword + +; Core ext 6.2.1485 +dword FALSE,"FALSE" + lda #$00 + tay + PUSHNEXT +eword + +; Core ext 6.2.2298 +dword TRUE,"TRUE" + lda #$ff + tay + PUSHNEXT +eword + +; Core 6.1.0270 +dword ZEROQ,"0=" + jsr popay ; flags reflect A reg + bne FALSE::xt + tya + bne FALSE::xt + beq TRUE::xt ; always +eword + +; Core ext 6.2.0280 +dword ZEROGT,"0>" + jsr popay + bmi FALSE::xt + bne TRUE::xt + tya + bne TRUE::xt + PUSHNEXT ; 0 if we got here +eword + +; Core 6.1.0530 +dword EQUAL,"=" + jsr _cmpcom + bne FALSE::xt + cpy WR + bne FALSE::xt + beq TRUE::xt +eword + +; Core 6.1.2340 +dword ULT,"U<" + jsr _cmpcom + bcc TRUE::xt + bne FALSE::xt + cpy WR + bcc TRUE::xt + bcs FALSE::xt +eword + +; Core ext 6.2.2350 +dword UGT,"U>" + jsr _cmpcom + bcc FALSE::xt + bne TRUE::xt + cpy WR + beq FALSE::xt + bcs TRUE::xt + bcc FALSE::xt +eword + +; Core 6.1.0480 +dword SLT,"<" + jsr _stest + bcc FALSE::xt + bcs TRUE::xt +eword + +; Core 6.1.0540 +dword SGT,">" + jsr _stest + beq FALSE::xt + bcc FALSE::xt + bcs TRUE::xt ; always +eword + +; Common routines for comparisons, appearing after them +; so that we can use relative branches +; all the unsigned comparisons begin this way +; ( u1 u2 -- ) +.proc _cmpcom + jsr popwr ; u2 to WR + jsr popay ; u1 to AY + cmp WR+1 ; compare u1h to A + rts +.endproc + +; ( n1 n2 -- ) 16 bit signed comparison +; C and Z flags reflect the same comparison results as the 8-bit +; CMP instruction (Z means equal, C means >= +.proc _stest + jsr popxr + jsr popwr + lda WR+1 + eor XR+1 + bpl same ; same-sign compare, good to go + lda WR ; otherwise do unsigned compare + cmp XR ; and note that opposite-signed #s can't be equal + lda WR+1 + sbc XR+1 + bvs :+ + eor #$80 +: sec ; Make sure Z flag is cleared + rol ; move comparison result into carry + rts +same: lda WR+1 + cmp XR+1 + bcc done ; if less than or not equal, done + bne done + lda WR + cmp XR +done: rts +.endproc + +; Core 6.1.1650 +; ( -- w ) +dword HERE,"HERE" + lda CHERE+1 + ldy CHERE + PUSHNEXT +eword + +; non-standard +; ( -- w ) +dword LAST,"LAST" + lda DLAST+1 + ldy DLAST + PUSHNEXT +eword + +dvar OLDHERE,"OLDHERE",0 + +; Core 6.1.1380 +dword DEXIT,"EXIT",F_CONLY + jmp exit_next +eword + +; _IF truecode +; headerless word compiled by IF +; jumps if the top of stack is false, otherwise +; skips jump addr and continues execution +hword _IF,"_IF" + jsr popay ; flags represent A reg + bne :+ + tya + bne :+ + jmp _JUMP::xt +: jmp _SKIP::xt +eword + +; _IFFALSE falsecode +; jumps if the top of stack is truthy, otherwise +; skips jump addr and continues execution +hword _IFFALSE,"_IFFALSE" + jsr popay ; flags represent A reg + bne :+ + tya + bne :+ + jmp _SKIP::xt +: jmp _JUMP::xt +eword + +; Core 6.1.1700 +dword IF,"IF",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _IF::xt ; compile _IF + .addr HERE::xt ; save to resolve later + .addr COMP_LIT::xt + .addr controlmm ; compile unresolved + EXIT +eword + +; Core 6.1.1310 +; ( orig1 -- orig2 ) +dword ELSE,"ELSE",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _JUMP::xt ; compile JUMP + .addr HERE::xt ; (o1 -- o1 o2 ) + .addr COMP_LIT::xt + .addr controlmm ; compile unresolved + .addr SWAP::xt ; (o1 o2 -- o2 o1 ) + .addr HERE::xt ; (o2 o1 -- o2 o1 addr ) + .addr SWAP::xt ; (o2 o1 addr -- o2 addr o1 ) + .addr STORE::xt ; (o2 o1 addr -- o2 ) resolve IF + EXIT +eword + +; Core 6.1.2270 +; (orig -- ) +dword THEN,"THEN",F_IMMED|F_CONLY + ENTER + .addr HERE::xt ; ( o1 -- o1 addr ) + .addr SWAP::xt ; ( o1 addr -- addr o1 ) + .addr STORE::xt ; ( o1 addr -- ) + EXIT +eword + +; Core 6.1.0760 +dword BEGIN,"BEGIN",F_IMMED|F_CONLY + ENTER + .addr HERE::xt + EXIT +eword + +; Core 6.1.2430 +; ( C: dest -- orig dest ) +dword WHILE,"WHILE",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt ; compile IF + .addr _IF::xt + .addr HERE::xt ; orig = new unresolved + .addr SWAP::xt ; underneath top + .addr COMP_LIT::xt ; compile unresolved + .addr controlmm + EXIT +eword + +; Core 6.1.2390 + +dword UNTIL,"UNTIL",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _IF::xt ; compile + .addr COMMA::xt ; compile false branch destination + EXIT +eword + +; Core 6.1.2140 +; ( C: orig dest -- ) +dword REPEAT,"REPEAT",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _JUMP::xt + .addr COMMA::xt ; compile _JUMP dest + .addr HERE::xt ; ( C: orig -- orig here ) + .addr SWAP::xt ; ( ... -- here orig ) + .addr STORE::xt ; resolve orig + EXIT +eword + +; Core ext 6.2.0700 +dword AGAIN,"AGAIN",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _JUMP::xt + .addr COMMA::xt + EXIT +eword + +; Core 6.1.0750 +; really a variable, but the address of the var is constant +dconst BASE,"BASE",ZBASE + +; Core ext 6.2.1660 +dword HEX,"HEX" + ldy #<16 + lda #>16 + sty ZBASE + sta ZBASE+1 + NEXT +eword + +; Core 6.1.1170 +dword DECIMAL,"DECIMAL" + ldy #<10 + lda #>10 + sty ZBASE + sta ZBASE+1 + NEXT +eword + +.if 0 +; non-standard +dword OCTAL,"OCTAL" + ldy #<8 + lda #>8 + sty ZBASE + sta ZBASE+1 + NEXT +eword +.endif + +.if 0 +; non-standard +dword BINARY,"BINARY" + ldy #<2 + lda #>2 + sty ZBASE + sta ZBASE+1 + NEXT +eword +.endif + +.proc _invertay + pha + tya + eor #$FF + tay + pla + eor #$FF + rts +.endproc + +; Core 6.1.1720 +; optimized for space +dword INVERT,"INVERT" + jsr popay + jsr _invertay + PUSHNEXT +eword + +.proc _negateay + pha + tya + eor #$FF + clc + adc #$01 + tay + pla + eor #$FF + adc #$00 + rts +.endproc + +; Core 6.1.1910 +; optimized for space +dword NEGATE,"NEGATE" + jsr popay + jsr _negateay + PUSHNEXT +eword + +; Non-standard +; ( d f -- d' ) if f < 0 then negate +hword QNEGATE,"?NEGATE" + jsr popay + and #$80 + beq :+ + jmp NEGATE::xt +: NEXT +eword + +; Core 6.1.0690 +dword ABS,"ABS" + lda PSTKH-1,x + bmi NEGATE::xt + NEXT +eword + +; Double-Number 8.6.1.1230 +dword DNEGATE,"DNEGATE" + jsr popay ; high cell + pha + tya + pha + jsr popay ; low cell + jsr _negateay + php + jsr pushay + plp + pla + eor #$FF + adc #$00 + tay + pla + eor #$FF + adc #$00 + PUSHNEXT +eword + +; Double-Number 6.1.0690 +dword DABS,"DABS" + lda PSTKH-1,x + bmi DNEGATE::xt + NEXT +eword + + +; Core 6.1.0290 +dword INCR,"1+" + cpx #$01 + bcc stku2 + inc PSTKL-1,x + bne :+ + inc PSTKH-1,x +: NEXT +stku2: jmp stku_err +eword +stku2 = INCR::stku2 + +; Core 6.1.0300 +dword DECR,"1-" + cpx #$01 + bcc stku2 + lda PSTKL-1,x + bne :+ + dec PSTKH-1,x +: dec PSTKL-1,x + NEXT +eword + +.proc m2parm + cpx #$02 + bcc stku2 + dex + lda PSTKL-1,x + rts +.endproc + +; Core 6.1.0120 +; would be faster if we could have the stack on the ZP... +dword PLUS,"+" + jsr m2parm + clc + adc PSTKL,x + sta PSTKL-1,x + lda PSTKH-1,x + adc PSTKH,x + sta PSTKH-1,x + NEXT +eword + +; Core 6.1.0160 +dword MINUS,"-" + jsr m2parm + sec + sbc PSTKL,x + sta PSTKL-1,x + lda PSTKH-1,x + sbc PSTKH,x + sta PSTKH-1,x + NEXT +eword + +; Core 6.1.1130 +dword PSTORE,"+!" + ENTER + .addr DUP::xt + .addr FETCH::xt + .addr ROT::xt + .addr PLUS::xt + .addr SWAP::xt + .addr STORE::xt + EXIT +eword + +; (n1 n2 -- ) n2->YR n1->ZR +.proc _setup2 + jsr popay + sta YR+1 + sty YR + jsr popay + sta ZR+1 + sty ZR + rts +.endproc + +; (n1 n2 n3 -- ) n3->YR n2(hw)->ZR n1(lw)->ZACC +.proc _setup3 + jsr _setup2 + jsr popay + sta ZACC+1 + sty ZACC + rts +.endproc + +; (n1 n2 -- ) n2->abs->YR n1->abs->ZR +; for division, divisor (remainder) sign stored in dsign +; result sign stored in rsign +.proc _setup2_signed + jsr popay + sta rsign + sta dsign ; divisor sign for symmetric division + bpl :+ ; popay sets sign correctly + jsr _negateay +: sta YR+1 + sty YR + jsr popay + sta fsign + pha + eor rsign ; compute result sign + sta rsign + pla + bpl :+ + jsr _negateay +: sta ZR+1 + sty ZR + rts +rsign: .byte $00 ; result sign +dsign: .byte $00 ; dividend sign +fsign: .byte $00 ; divisor sign +.endproc + +.proc _multcommon + jsr _setup2 +nosetup: txa + pha + jsr _umult + pla + tax + rts +.endproc + +.proc _smultcommon + jsr _setup2_signed + jmp _multcommon::nosetup +.endproc + +; Core 6.1.2360 +dword UMMULT,"UM*" + jsr _multcommon +push: lda ZACC+1 + ldy ZACC + jsr pushay + lda ZACC+3 + ldy ZACC+2 + PUSHNEXT +eword + +; Core 6.1.1810 +dword MMULT,"M*" + jsr _smultcommon + bit _setup2_signed::rsign + bpl UMMULT::push ; just push if result not negative + lda ZACC+1 + ldy ZACC + jsr _negateay ; negate the low word + php ; and save carry + jsr pushay + plp ; restore carry + lda ZACC+2 ; negate high word + eor #$FF + adc #$00 + tay + lda ZACC+3 + eor #$FF + adc #$00 + PUSHNEXT +eword + +; Core 6.1.0090 +dword MULT,"*" + ENTER + .addr MMULT::xt + .addr DROP::xt + EXIT +eword + +.proc _divcommon + jsr _setup2 +signed: lda YR + ora YR+1 + bne :+ +divzero: ldy #<-10 + lda #>-10 + jmp _throway +: txa + pha + jsr _udiv + pla + tax + rts +.endproc + +.proc _udivmod + jsr _divcommon +push: lda ZACC1+1 ; remainder + ldy ZACC1 + jsr pushay +quot: lda ZR+1 ; quotient + ldy ZR + jsr pushay + rts +.endproc + +; Core 6.1.2370 +dword UMDIVMOD,"UM/MOD" + jsr _setup3 + lda YR + ora YR+1 + beq _divcommon::divzero + txa + pha + jsr _umdiv + pla + tax + lda ZR+1 + ldy ZR + jsr pushay + lda ZACC+1 + ldy ZACC + PUSHNEXT +eword + +.proc _sdivcommon + jsr _setup2_signed + jmp _divcommon::signed ; go do signed division +.endproc + +; non-standard, 16-bit toward-zero signed division +dword SDIVREM,"S/REM" + jsr _sdivcommon +sames: lda ZACC+1 ; get remainder + ldy ZACC + bit _setup2_signed::rsign ; result sign + bpl :+ + jsr _negateay +: bit _setup2_signed::dsign ; remainder sign + bpl :+ + jsr _negateay +: jsr pushay + lda ZR+1 + ldy ZR + bit _setup2_signed::rsign ; quotient sign + bpl :+ + jsr _negateay +: PUSHNEXT +eword + +; non-standard, 16-bit floored signed division +dword FDIVMOD,"F/MOD" + jsr _sdivcommon + lda _setup2_signed::rsign ; result sign + bpl SDIVREM::sames ; if not negative + lda ZACC+1 + ldy ZACC + jsr _invertay + bit _setup2_signed::fsign ; divisor sign = remainder sign + bpl :+ ; already negative + jsr _negateay +: jsr pushay + lda ZR+1 + ldy ZR + jsr _invertay + PUSHNEXT +eword + +; Core 6.1.0240 +; implemented as resolved deferred word so that it may be changed +; from floored to symmetric +dword DIVMOD,"/MOD" + jmp FDIVMOD::xt +eword + +; Core 6.1.1890 +dword MOD,"MOD" + ENTER + .addr DIVMOD::xt + .addr DROP::xt + EXIT +eword + +; Core 6.1.0230 +dword DIV,"/" + ENTER + .addr DIVMOD::xt + .addr SWAP::xt + .addr DROP::xt + EXIT +eword + +.proc logcom1 + jsr popwr + jsr popay + rts +.endproc + +; Core 6.1.0720 +dword LAND,"AND" + jsr logcom1 + and WR+1 + pha + tya + and WR +com2: tay + pla + PUSHNEXT +eword +logcom2 = LAND::com2 + +; Core 6.1.1980 +dword LOR,"OR" + jsr logcom1 + ora WR+1 + pha + tya + ora WR + jmp logcom2 +eword + +; Core 6.1.2450 +dword LXOR,"XOR" + jsr logcom1 + eor WR+1 + pha + tya + eor WR + jmp logcom2 +eword + +; Core 6.1.2214 +dword SMDIVREM,"SM/REM" + ENTER + .addr TWODUP::xt + .addr LXOR::xt + .addr PtoR::xt + .addr OVER::xt + .addr PtoR::xt + .addr ABS::xt + .addr PtoR::xt + .addr DABS::xt + .addr RtoP::xt + .addr UMDIVMOD::xt + .addr SWAP::xt + .addr RtoP::xt + .addr QNEGATE::xt + .addr SWAP::xt + .addr RtoP::xt + .addr QNEGATE::xt + EXIT +eword + +hword SIGNUM,"SIGNUM" + ENTER + .addr DUP::xt + .addr ZEROLT::xt + .addr SWAP::xt + .addr ZEROGT::xt + .addr MINUS::xt + EXIT +eword + +; Core 6.1.1561 +dword FMDIVMOD,"FM/MOD" + ENTER + .addr DUP::xt + .addr PtoR::xt + .addr SMDIVREM::xt + .addr OVER::xt + .addr SIGNUM::xt + .addr RCOPY::xt + .addr SIGNUM::xt + .addr NEGATE::xt + .addr EQUAL::xt + .addr _IF::xt + .addr _else + .addr DECR::xt + .addr SWAP::xt + .addr RtoP::xt + .addr PLUS::xt + .addr SWAP::xt + EXIT +_else: .addr RDROP::xt + EXIT +eword + +; Non standard +; implemented as resolved deferred word so that it may be changed +; from floored to symmetric for derived words +dword MDIVMOD,"M/MOD" + jmp FMDIVMOD::xt +eword + +; Core 6.1.0110 +dword MULTDIVMOD,"*/MOD" + ENTER + .addr PtoR::xt + .addr MMULT::xt + .addr RtoP::xt + .addr MDIVMOD::xt + EXIT +eword + +; Core 6.1.0100 +dword MULTDIV,"*/" + ENTER + .addr MULTDIVMOD::xt + .addr NIP::xt + EXIT +eword + +; Davex +; read key ( c1 -- c2 ) +; c1 = char to place under cursor +; c2 = key that is read +dword XKEY,"XKEY" + jsr popay + tya + stx SPTMP + jsr xrdkey + and #$7F + ldx SPTMP + jsr pusha + NEXT +eword + +; Core 6.1.1750 +dword KEY,"KEY" + ENTER + NLIT ' ' + .addr XKEY::xt + EXIT +eword + +; Facility 10.6.1.1755 +dword KEYQ,"KEY?" + lda $C000 + and #$80 + beq :+ + lda #$FF +: tay + PUSHNEXT +eword + +; Facility 10.6.1.1755 +dword PAGE,"PAGE" + lda #AFF + jsr _emit + NEXT +eword + +; non-standard +dword HTAB,"HTAB" + jsr popay + sty CH + NEXT +eword + +; non-standard +dword VTAB,"VTAB" + jsr popay + tya + jsr TabV ; preserves x + NEXT +eword + +; Facility 10.6.1. +dword ATXY,"AT-XY" + ENTER + .addr VTAB::xt + .addr HTAB::xt + EXIT +eword + +; Non-standard in 2012, former standard +; note this is NOT a dconst because INBUF +; isn't set until run-time! +hword TIB,"TIB" + lda INBUF+1 + ldy INBUF + PUSHNEXT +eword + +; non-standard, current input buffer +hvar CIB,"CIB",0 + +; Core ext 6.2.2218 +dword SOURCEID,"SOURCE-ID",0 + ENTER + .addr dSOURCEID::xt + .addr FETCH::xt + EXIT +eword + +; Core 6.1.0560 +dvar PIN,">IN",0 + +; Non-standard, # of chars in input buffer +hvar NIN,"#IN",0 + +; Non-standard +; return false if there is no more input +; true if there is +hword INQ,"IN?" + ENTER + .addr PIN::xt + .addr FETCH::xt + .addr NIN::xt + .addr FETCH::xt + .addr UGT::xt + .addr ZEROQ::xt + EXIT +eword + +; Core 6.1.2216 +; address & content length of source input buffer +dword SOURCE,"SOURCE" + ENTER + .addr CIB::xt + .addr FETCH::xt + .addr NIN::xt + .addr FETCH::xt + EXIT +eword + +; Non-standard +; Headerless helper to compute current input buffer char address +hword INPTR,"INPTR" + ENTER + .addr PIN::xt + .addr FETCH::xt + .addr CIB::xt + .addr FETCH::xt + .addr PLUS::xt + EXIT +eword + +; Non-standard +; headerless helper to increment the input pointer +hword INC_INPTR,"INPTR+" + ENTER + NLIT 1 + .addr PIN::xt + .addr PSTORE::xt + EXIT +eword + +; Non-standard +; read current input ( -- c ) +hword GETCH,"GETCH" + ENTER + .addr INPTR::xt + .addr CFETCH::xt + .addr INC_INPTR::xt + EXIT +eword + +; Davex +; return redirect status +; ( -- f1 f2 ) -- f1 is input redirect status, f2 is output redirect status +dword REDIRECTQ,"REDIRECT?" + stx SPTMP + lda #$00 + jsr xredirect + ldx SPTMP + pha + and #%01000000 + jsr :+ + pla + and #%10000000 + jsr :+ + NEXT + beq :+ + lda #$FF +: tay + jsr pushay + rts +eword + +; Non-standard helper to set input source to keyboard or redirect +hword SETKBD,"STKBD" + ENTER + .addr TIB::xt + .addr CIB::xt + .addr STORE::xt +dokbd: NLIT 0 +doany: .addr dSOURCEID::xt + .addr STORE::xt + EXIT +eword + +; Davex +dconst XMAXLEN,"MAXLEN",(maxlen) + +; ( c-addr n1 -- n2 ) +; get up to n1 chars from the user's keyboard into the buffer +; at c-addr, returning in n2 the # of characters accepted +; n1 should not be greater than MAXLEN +; since davex returns a counted string, we will convert it in situ +.proc _accept + trace "_accept" + jsr popay ; pop n1 + sty XR ; save max length + jsr popwr ; pop c-addr + lda WR ; now use c-addr minus 1 + bne :+ + dec WR+1 +: dec WR + ldy #$00 + lda (WR),y ; grab byte where length will go + pha ; and save it + stx SPTMP ; save PSP + lda WR+1 + ldy WR + ldx XR + inx ; account for length byte + jsr xgetln2 ; AY=buffer, X=max length + ldx SPTMP ; restore PSP + ldy #$00 ; now get returned length + lda (WR),y + sta XR ; and save it + pla ; restore byte where length went + sta (WR),y + lda XR + jmp pusha +.endproc + +; Core 6.1.0695 +dword ACCEPT,"ACCEPT" + jsr _accept + NEXT +eword + +hword dREFILL,"$REFILL" + lda SOURCE_ID + ora SOURCE_ID+1 + beq keyboard + lda SOURCE_ID+1 + cmp #SRC_REDIR + beq keyboard ; redirected simulates keyboard input + cmp #SRC_ARG + beq filearg + ldy #<-57 + lda #>-57 + jmp _throway ; to be implemented later, potentially +filearg: ldy #$00 +: stx SPTMP + sty YR + lda SOURCE_ID + jsr xfman_read + ; jsr _emit ; uncomment for input echo + ldy YR + ldx SPTMP + bcs filerr + and #$7F + cmp #ACR + beq :+ + sta (INBUF),y + iny + bne :- ; go until 256 chars if no CR + lda #$01 ; $0100 + bne :++ ; always +: lda #$00 ; $00yy +: jsr pushay + jmp accepted ; accepted, go ahead +filerr: cmp #$4C + bne noteof + cpy #$00 + bne accepted ; got some chars before EOF, go interpret + tya + jsr pushay ; FALSE onto stack + jmp SETKBD::xt ; and switch to keyboard input +noteof: jmp _throwp8 ; throw ProDOS error +keyboard: stx SPTMP ; set source ID to reflect keyboard + lda #$00 + jsr xredirect ; or redirection depending on status + ldx SPTMP ; of redirection + and #%01000000 + beq :+ + lda #SRC_REDIR +: sta SOURCE_ID+1 + lda INBUF+1 + ldy INBUF + jsr pushay + lda #maxlen + jsr pusha + jsr _accept ; accept input + jsr peekay ; get length + tya ; into a + beq accepted ; do nothing on empty buffer + dey ; account for zero-based index +lp: lda (INBUF),y ; mask off all high bits + and #$7F + sta (INBUF),y + dey + cpy #$FF ; can't use minus or zero + bne lp +accepted: ENTER + .addr NIN::xt ; #IN + .addr STORE::xt ; write count + NLIT 0 ; now reset >IN + .addr PIN::xt + .addr STORE::xt ; 0 >IN ! + .addr TRUE::xt ; and always return true + EXIT +eword + +; Core ext 6.2.2125 +dword REFILL,"REFILL" + jmp dREFILL::xt +eword + +; make dictionary entry for word at WR, length in XR +; returns with position of new word in AY +.proc _mkdict + ldy XR + beq badword + cpy #$10 + bcs badword + lda CHERE+1 ; save HERE for return + pha + lda CHERE + pha + lda DLAST+1 ; get LAST word + ldy DLAST + jsr cworday ; compile link + lda XR + ora #$80 ; default flags+length + jsr cbytea + ldy #$00 +: cpy XR + beq done + lda (WR),y + jsr _wconva ; normalize to upper case + sty YR + jsr cbytea ; compile byte (wrecks Y) + ldy YR + iny + bne :- +done: pla ; get old HERE + tay + pla + rts +badword: ldy #<-19 ; definition name too long + lda #>-19 + jmp _throway +.endproc + +; Convert to upper case +.proc _wconva + and #$7F + cmp #'z'+1 ; upper case conversion + bcs :+ ; not standard... + cmp #'a' + bcc :+ + and #$DF +: rts +.endproc + +; search dictionary for word at WR, length in XR +; if found, AY != 0 and carry set +; otherwise carry clear and AY=0 +.proc _search + trace "_search" + lda DLAST+1 ; TODO: move this out if search order + ldy DLAST ; words are implemented +olp: sta ZR+1 + sty ZR + ora ZR + beq notfnd + ldy #$02 ; offset of len+flags + lda (ZR),y + and #F_SMUDG ; see if smudged (invisible) + bne snext + lda (ZR),y ; otherwise next... + and #$0F ; mask in length + cmp XR + bne snext + lda ZR + clc + adc #$03 ; offset to name start + sta chkchr + lda ZR+1 + adc #$00 + sta chkchr+1 + ldy XR + dey ; from 1-based to 0-based +ilp: lda (WR),y + jsr _wconva ; normalize (non-standard) + cmp *,y ; self-modified +chkchr = * - 2 + bne snext ; nope + dey + bpl ilp + sec ; loop end, found it! +done: lda ZR+1 + ldy ZR + rts +notfnd: clc + bcc done +snext: ldy #$01 ; get pointer to next word + lda (ZR),y ; into AX + pha + dey + lda (ZR),y + tay + pla + jmp olp +.endproc + +; non-standard +hword DSEARCH,"$SEARCH" + jsr popxr + jsr popwr + lda XR+1 + eor XR + beq none + jsr _search + bcs :+ +none: lda #$00 + tay +: PUSHNEXT +eword + +; with word head in AY +; find code address and put in AY +; set S and V flags to reflect immediate and compile-only flags +; return carry set always +.proc _code + sta ldlen+1 + tya + clc + adc #$02 + sta ldlen + bcc :+ + inc ldlen+1 +: lda * ; self-modified +ldlen = * - 2 + sta flags + and #$0F ; mask length + sec ; extra one byte to line up + adc ldlen ; add back into low byte + tay + lda ldlen+1 + adc #$00 + asl flags + bit flags + sec + rts +flags: .byte $00 +.endproc + +; Non-standard +hword DFLAGS,"$FLAGS" + ENTER + .addr DUP::xt + .addr ZEROQ::xt + .addr _IF::xt + .addr ok + EXIT +ok: NLIT 2 + .addr PLUS::xt + EXIT +eword + +; Non-standard +hword DXT,"$XT" + jsr popay + cmp #$00 + bne :+ + cpy #$00 + beq done +: jsr _code +done: PUSHNEXT +eword + +.proc searcherr + ldy #<-13 ; undefined word + lda #>-13 + jmp _throway +.endproc + +; Core 6.1.0550 +dword rBODY,">BODY" + jsr popwr + clc +jmponly: ldy #$00 + lda (WR),y + bcs ckjmp + ldy #$03 + cmp #opJSR + beq :+ +ckjmp: ldy #$01 + cmp #opJMP + beq :+ + ldy #<-31 ; not a word for which a body may be found + lda #>-31 + jmp _throway +: tya + clc + adc WR + tay + lda WR+1 + adc #$00 + PUSHNEXT +eword +; headerless get body of JMP only +hword _rJMP,">JMP" + jsr popwr + sec + bcs rBODY::jmponly +eword + +.proc _cold + trace "_cold" + lda #BYE::xt + sta IP+1 + lda #$00 + ldx #$17 ; np ZP,y +: sta xczpage,x ; clear system stuff + dex + bpl :- + lda #10 + sta ZBASE + lda IHERE+1 + sta CHERE+1 + lda IHERE + sta CHERE + lda #ELAST + sta DLAST+1 + lda #X_DX_LOAD + sta HIMEM+1 + dec HIMEM+1 + ldy #$FE + tya + sta (HIMEM),y + iny + sta (HIMEM),y + inc HIMEM+1 + lda SOURCE_ID+1 + cmp #SRC_ARG + bne :+ + jmp FQUIT_xt +; greetings! +: lda #$00 + jsr xredirect ; determine if I/O is redirected + and #%11000000 ; mask in bits + bne abort ; and skip greeting if redirected + jsr xmess + .byte "MG's Davex Forth ",$00 + lda version + jsr xprint_ver + jsr xmess + .byte $8D,$00 +; non-exception abort +abort: ldx #$00 ; init data stack pointer + jmp QUIT_xt +.endproc +_abort = _cold::abort + +; see if last word needs forgetting due to exception +; in the middle of defining it +.proc _patch + trace "_patch" + lda DLAST ; see if last word needs forgetting + sta WR + lda DLAST+1 + sta WR+1 + ldy #$02 + lda (WR),y ; get smudge bit +chk = * - 2 + and #F_SMUDG ; mask off smudge flag + bne :+ ; fix up if smudged + rts ; otherwise do nothing +: ldy #$01 + lda (WR),y + sta DLAST+1 + dey + lda (WR),y + sta DLAST + lda OLDHERE::val+1 + sta CHERE+1 + lda OLDHERE::val + sta CHERE + rts +.endproc + +; non-standard helper to return address of WORD buffer, which +; starts at 16 past HERE +hword WORDBUF,"WORDBUF" + ENTER + .addr HERE::xt + NLIT 16 + .addr PLUS::xt + EXIT +eword + +; Core ext 6.2.2000 +; PAD is immediately after WORDBUF +dword PAD,"PAD" + ENTER + .addr WORDBUF::xt + NLIT WORD_SIZE + .addr PLUS::xt + EXIT +eword + +; Core 6.1.2070 +dword RFETCH,"R@" + stx SPTMP + tsx + pla + sta WR + pla + txs + ldx SPTMP + ldy WR + PUSHNEXT +eword + +; Core 6.1.2170 +dword StoD,"S>D" + jsr peekay + and #$80 + beq :+ + lda #$FF +: tay + jsr pushay + NEXT +eword + +; non-standard +; ( x1 x2 -- d1 d2 ) +dword TWOStoD,"2S>D" + ENTER + .addr PtoR::xt + .addr StoD::xt + .addr RtoP::xt + .addr StoD::xt + EXIT +eword + +; Core 6.1.0770 +dword BL,"BL" + lda #' ' + jsr pusha + NEXT +eword + +; Core 6.1.2220 +dword SPACE,"SPACE" + lda #' ' ; asm version 1 byte shorter + jsr _emit + NEXT +eword + +; Core 6.1.0990 +dword CR,"CR" + lda #ACR ; asm version 1 byte shorter + jsr _emit + NEXT +eword + +; helper to convert digit to char +.proc _tochar + clc + adc #'0' + cmp #'9'+1 + bcc :+ + adc #6 + cmp #'Z' + bcc :+ + adc #6 +: rts +.endproc + +; routine to convert char to digit +.proc _todigit + pha + lda ZBASE ; cheating, no high byte! + cmp #36 + pla + bcs :+ + jsr _wconva + sec +: sbc #'0' ; 0-9 conversion + bmi bad + cmp #10 ; if less than 10 we are good + bcc good + sbc #7 ; A-Z conversion + bmi bad + cmp #37 + bcc good ; good if less than 37 + sbc #7 ; a-z conversion + bmi bad +good: sec + rts +bad: clc + rts +.endproc + +; routine to convert a number at WR len XR +; start by initializing current number to 0 +; then for each digit left-to-right, multiply the number +; by the current radix in BASE and adding the digit +; return carry set if conversion was successful +; and number in AY +.proc _parsenum + trace "_parsenum" + clc + ror mflag + ldy #$00 ; clear y and use it to + sty YR ; init 2nd multiplicand + sty YR+1 ; which also accumulates total +pnum2: stx SPTMP ; data SP gonna get trashed + lda ZBASE + sta ZR ; ZR undisturbed by multiply + lda ZBASE+1 ; so first multiplicand will be base + sta ZR+1 + ;ldy #$00 + sty nflag +lp: sty XR+1 ; save Y + jsr _umult ; since _umult kills it + lda ZACC ; copy results to 2nd multiplicand + sta YR + lda ZACC+1 + sta YR+1 + ldy XR+1 ; get Y back + lda (WR),y ; now grab a char to convert + and #$7F ; strip high bit + cmp #'-' + beq minus + jsr _todigit ; convert to digit + bcc bad + cmp ZBASE ; make sure smaller than base + bcs bad ; (cheating by not checking high byte) + clc ; now add to accumulating value + adc YR + sta YR + bcc :+ + inc YR+1 +: iny ; count # of digits processed + sty XR+1 ; and save count for interested parties + cpy XR ; and see if we are done + bcc lp ; (if not, keep going) +done: lda YR+1 ; and return the # + ldy YR + ldx SPTMP + bit nflag + bpl :+ + jsr _negateay +: sec + rts +bad: bit mflag + bmi done + ldx SPTMP + clc + rts +minus: bit mflag + bmi bad + cpy #$00 + bne bad + ror nflag ; carry is set + iny + bne lp +nflag: .byte $00 +mflag: .byte $00 +.endproc + +; Core 6.1.0570 +dword GNUMBER,">NUMBER" + jsr popxr + jsr popwr + jsr popay + sta ZR+1 + sty ZR + ldy #$00 + sec + ror _parsenum::mflag + jsr _parsenum::pnum2 + jsr pushay + lda WR + clc + adc XR+1 + tay + lda WR+1 + adc #$00 + jsr pushay + lda XR + sec + sbc XR+1 + jsr pusha + NEXT +eword + +; backing variable for pictured numeric output +hvar dPPTR,"$PPTR",0 + +; Core 6.1.0490 +dword PBEGIN,"<#" + ENTER + .addr WORDBUF::xt + NLIT WORD_SIZE + .addr PLUS::xt + .addr dPPTR::xt + .addr STORE::xt + EXIT +eword + +; Core 6.1.1670 +; ( c -- ), put c into pictured numeric output buffer +dword PHOLD,"HOLD" + ENTER + .addr dPPTR::xt ; Current pictured output pointer var + .addr FETCH::xt ; get the saved address + .addr DECR::xt ; move to next lower address + .addr DUP::xt ; make a second copy + .addr dPPTR::xt + .addr STORE::xt ; write back to pointer var + .addr CSTORE::xt ; write character to location + EXIT +eword + +; Core 6.1.2210 +dword PSIGN,"SIGN" + jsr popay + and #$80 + beq :+ + lda #'-' + jsr pusha + jmp PHOLD::xt +: NEXT +eword + +; non-standard, unsigned divide 32-bit by 16-bit +; leaving 32-bit quotient and 16-bit remainder +; ( ud u -- u-rem ud-quot ) +; borrowed from sixtyforth +dword UMLDIVMOD,"UML/MOD" + ENTER + .addr PtoR::xt + .addr RCOPY::xt + NLIT 0 + .addr SWAP::xt + .addr UMDIVMOD::xt + .addr RtoP::xt + .addr SWAP::xt + .addr PtoR::xt + .addr UMDIVMOD::xt + .addr RtoP::xt + EXIT +eword + +; Core 6.1.0030 +dword PNUM,"#" + ENTER + .addr BASE::xt + .addr FETCH::xt + .addr UMLDIVMOD::xt ; divide by BASE + .addr ROT::xt ; put remainder in front + CODE + jsr popay ; get remainder + tya ; only low byte is practical + jsr _tochar ; convert to ASCII + jsr pusha ; and back onto stack + jmp PHOLD::xt ; then put in output buffer +eword + +; Core 6.1.0050 +dword PNUMS,"#S" + ENTER +another: .addr PNUM::xt + .addr TWODUP::xt + .addr LOR::xt + .addr _IFFALSE::xt ; is zero? + .addr another ; nope, do another digit + EXIT +eword + +; Core 6.1.0040 +; ( xd -- c-addr u ) +dword PDONE,"#>" + ENTER + .addr TWODROP::xt ; drop remaining quotient +getstr: .addr dPPTR::xt ; c-addr + .addr FETCH::xt + .addr WORDBUF::xt ; now compute u + NLIT WORD_SIZE + .addr PLUS::xt + .addr dPPTR::xt + .addr FETCH::xt + .addr MINUS::xt + EXIT +eword + +; general number formatter for standard number output words +; it's slow, but it does it all and saves space with the words that follow +; ( d u1 f -- c-addr u2 ) u1 = field size f = true if signed output desired +hword DFMT,"DFMT" + ENTER + .addr SWAP::xt + .addr PtoR::xt + .addr PBEGIN::xt + .addr _IF::xt ; check f + .addr us1 ; unsigned if f is false + .addr DUP::xt ; duplicate cell with sign + .addr NROT::xt ; and put it behind d + .addr DABS::xt + .addr _SKIP2::xt ; skip next 2 words +us1: NLIT 0 ; no sign printed + .addr NROT::xt + .addr PNUMS::xt ; perform conversion + .addr ROT::xt ; get sign back to front + .addr PSIGN::xt ; add sign if needed + .addr PDONE::xt + .addr RtoP::xt ; get field size back + .addr MINUS::xt ; if less than 0, have to add blanks +lp: .addr DUP::xt + .addr ZEROLT::xt ; is less than 0? + .addr _IF::xt + .addr fielddn ; nope, done + .addr INCR::xt ; increment + .addr BL::xt + .addr PHOLD::xt ; hold a blank + .addr _JUMP::xt ; and go back to lp + .addr lp +fielddn: .addr TWODROP::xt ; drop c-addr and leftovers + .addr _JUMP::xt + .addr PDONE::getstr ; and return c-addr u for result +eword + +; Double-number 8.6.1070 +dword DDOTR,"D.R" + ENTER +dosdotr: NLIT 1 ; signed +dodotr: .addr DFMT::xt + .addr TYPE::xt + EXIT +eword + +; Double-number 8.6.1060 +dword DDOT,"D." + ENTER + NLIT 0 ; field size + .addr DDOTR::xt + .addr SPACE::xt + EXIT +eword + +; Core ext 6.2.2330 +dword UDOTR,"U.R" + ENTER + .addr PtoR::xt + NLIT 0 ; unsigned S>D + .addr RtoP::xt + NLIT 0 ; want unsigned + .addr _JUMP::xt + .addr DDOTR::dodotr +eword + +; Core ext 6.2.0210 +dword DOTR,".R" + ENTER + .addr PtoR::xt + .addr StoD::xt + .addr RtoP::xt + .addr _JUMP::xt + .addr DDOTR::dosdotr +eword + +; Core 6.1.2320 +dword UDOT,"U." +.if 0 + ; faster + ENTER + NLIT 0 ; unsigned S>D + .addr PBEGIN::xt + .addr PNUMS::xt + .addr PDONE::xt + .addr TYPE::xt + .addr SPACE::xt + EXIT +.else + ; smaller + ENTER + NLIT 0 + .addr UDOTR::xt + .addr SPACE::xt + EXIT +.endif +eword + +; Core 6.1.0180 +dword DOT,"." +.if 0 + ; faster + ENTER + .addr StoD::xt + .addr _IF::xt + .addr pos + NLIT '-' + .addr EMIT::xt + .addr ABS::xt +pos: .addr UDOT::xt + EXIT +.else + ; smaller + ENTER + NLIT 0 + .addr DOTR::xt + .addr SPACE::xt + EXIT +.endif +eword + +; Core 6.1.1900 +dword MOVE,"MOVE" + jsr _swap + jsr popay + sta YR+1 + sty YR + ldy #func + jsr string_op_ay + NEXT +func: sta (YR),y + inc YR + bne :+ + inc YR+1 +: rts +eword + +; non-standard +; ( c-addr1 u c-addr2 -- ) place string at (c-addr1,u) in counted form +; at c-addr 2 +dword PLACE,"PLACE" + ENTER + .addr TWODUP::xt + .addr STORE::xt + .addr INCR::xt + .addr SWAP::xt + .addr MOVE::xt + EXIT +eword + +; Davex +dword PRP8ERR,".P8_ERR" + jsr popay + tya + stx SPTMP + jsr xProDOS_er + ldx SPTMP + NEXT +eword + +.proc _message + jsr peekay + cmp #P8_ER_RNG + beq PRP8ERR::xt + stx SPTMP + jsr xmess + .byte "Msg #",$00 + ldx SPTMP + ENTER + .addr DOT::xt + EXIT +.endproc + +; Non-standard +; This appears as a deferrable +; to be overridden by something more helpful later +dword MESSAGE,"MESSAGE" + jmp _message +eword + +; Exception 9.6.1.0875 +; push exception stack frame onto stack and execute token +dword CATCH,"CATCH" + jsr popwr ; remove xt from stack + inc flag ; flag catch active + lda IP+1 ; save IP on stack + pha + lda IP + pha + lda rstk ; save old catch return stack if any + pha + txa ; save data stack pointer + pha + stx SPTMP + tsx ; save return stack pointer + stx rstk + ldx SPTMP + lda WR+1 ; put xt back on stack + ldy WR + jsr pushay + ENTER + .addr EXECUTE::xt + CODE + ; if we got here, no exception + lda #$00 + sta WR + sta WR+1 + pla ; drop old data stack ptr +fixup: pla + sta rstk + pla + sta IP ; restore previous IP + pla + sta IP+1 + dec flag + lda WR+1 + ldy WR + PUSHNEXT +flag: .byte $00 +rstk: .byte $00 +eword + +; Exception 9.6.1.2275 +dword THROW,"THROW" + jsr peekay + ora #$00 + bne :+ + tya + bne :+ + dex ; peek told us there was at least one item + NEXT +: jsr popwr +ithrow: +.if TRACE + txa + pha + lda WR + sta TRADR + lda WR+1 + sta TRADR+1 + jsr xmess + .byte "[THROW,",$00 + jsr _dtrace + lda #']' + jsr _emit + pla + tax +.endif + lda CATCH::flag ; see if active CATCH + beq uncaught + ldx CATCH::rstk ; restore prior return stack ptr + txs + pla ; restore prior data stack ptr + tax + jmp CATCH::fixup ; now "return" from catch +uncaught: lda #$FF + cmp WR+1 + bne :+ + lda WR + cmp #<-1 + beq abort + cmp #<-2 + beq abort +: stx SPTMP + jsr xmess + .byte " Uncaught: ",$00 + ldx SPTMP + cpx #PSTK_SZ-10 ; check space left in parameter stack + bcc :+ ; and reserve enough to handle the + ldx #PSTK_SZ-10 ; error if needed +: lda WR+1 + ldy WR + jsr pushay + ENTER + .addr MESSAGE::xt + CODE + jmp QUIT_xt +abort: jmp _abort +eword + +; Throw an exceptiopn because of a ProDOS 8 error. +.proc _throwp8 + tay + lda #P8_ER_RNG + ; fall through to _throway +.endproc + +; this word bypasses the stack ops and executes throw +; the contents of AX should *not* be zero +.proc _throway + sta WR+1 + sty WR + jmp THROW::ithrow +.endproc + +; non-standard parse helper +hword ISSPC,"ISSPACE?" + ENTER + .addr BL::xt + .addr INCR::xt + .addr ULT::xt + EXIT +eword + +; non-standard parse helper +hword ISNOTSPC,"ISNOTSPACE?" + ENTER + .addr ISSPC::xt + .addr ZEROQ::xt + EXIT +eword + +; Core ext 6.2.2020 +; ( "name" -- c-addr u ) +dword PARSE_NAME,"PARSE-NAME" + ENTER +l1: .addr INQ::xt ; is there input? + .addr _IF::xt ; + .addr none ; if not, just return empty-handed + .addr GETCH::xt ; get char ( -- c ) + .addr ISSPC::xt ; is it a space? ( -- tf ) + .addr _IFFALSE::xt ; or, rather if not ( tf -- ) + .addr l1 ; do loop if it is + .addr INPTR::xt ; ( -- c-addr ) + .addr DECR::xt ; fixup because INPTR is 1 ahead now + NLIT 0 ; and we have 1 char ( -- c-addr u=1 ) +l2: .addr INQ::xt ; is there input? + .addr _IF::xt + .addr e1 ; if not, exit + .addr INCR::xt ; ( c-addr u -- c-addr u=u+1 ) count non-spaces + .addr GETCH::xt ; ( c-addr u -- c-addr u c ) + .addr ISSPC::xt ; ( c-addr u c -- c-addr u n ) + .addr _IF::xt ; ( c-addr u n -- c-addr u tf ) + .addr l2 ; not a space, keep parsing +e1: EXIT +none: .addr INPTR::xt + NLIT 0 + EXIT +eword + +; Core ext 6.2.2020 +dword PARSE,"PARSE" + ENTER + .addr PtoR::xt ; save delimeter + .addr INPTR::xt ; get current input address + NLIT 0 ; and start with a count of 0 +l1: .addr INQ::xt ; is there input available? + .addr _IF::xt + .addr e1 ; false branch exits + .addr GETCH::xt ; get the next char + .addr RCOPY::xt ; and copy the delimiter from return stack + .addr EQUAL::xt ; is it the same char? + .addr _IF::xt + .addr i1 ; false branch increments count and continues loop +e1: .addr RDROP::xt + EXIT +i1: .addr INCR::xt + .addr _JUMP::xt + .addr l1 +eword + +; Core 6.1.2450 +; ( char "ccc" -- c-addr ) +dword WORD,"WORD" + ENTER + .addr PARSE::xt ; ( char -- c-addr u ) parse the word + .addr DUP::xt ; dup count + NLIT WORD_SIZE ; max size of word space + .addr ULT::xt ; unsigned < + .addr _IF::xt ; was it less than? + .addr bad ; nope, error + .addr DUP::xt ; dup length again + .addr WORDBUF::xt ; address of word buf + .addr CSTORE::xt ; store length + .addr WORDBUF::xt ; wordbuf again + .addr INCR::xt ; +1 + .addr SWAP::xt ; make sure stack is ( c-addr u ) + .addr MOVE::xt ; move the data + .addr WORDBUF::xt ; and put word buffer address on stack + EXIT +bad: NLIT -18 ; "parsed string overflow" + .ADDR THROW::xt ; never returns +eword + +; Core 6.1.0895 +dword CHAR,"CHAR" + ENTER + .addr PARSE_NAME::xt + .addr DROP::xt + .addr CFETCH::xt + EXIT +eword + +; helper for words that must parse and find +; a dictionary entry +hword PARSEFIND,"$WORD" + ENTER + .addr PARSE_NAME::xt + .addr DSEARCH::xt + .addr DUP::xt + .addr _IF::xt + .addr exc + EXIT +exc: .addr DROP::xt + NLIT -13 + .addr THROW::xt +eword + +; Core 6.1.2520 +dword CCHAR,"[CHAR]",F_CONLY|F_IMMED + ENTER + .addr CHAR::xt + .addr COMMA::xt ; compile fast literal + EXIT +eword + +; helper +.proc _parsenametowrxr + ENTER + .addr PARSE_NAME::xt + CODE + jsr popxr + jmp popwr +.endproc + +; Core 6.1.0070 +dword FIND,"'" + ENTER + .addr PARSEFIND::xt + .addr DXT::xt + EXIT +eword + +; Core 6.1.2510 +dword CFIND,"[']",F_CONLY|F_IMMED + ENTER + .addr FIND::xt ; find xt + .addr COMP_LIT::xt + .addr LIT::xt ; compile LIT + .addr COMMA::xt ; compile xt as literal + EXIT +eword + +; Headerless helper to make a new dictionary entry +hword MKENTRY,"MKENTRY" + ENTER + .addr PARSE_NAME::xt + .addr HERE::xt ; if successfully parsed, set OLDHERE + .addr OLDHERE::xt + .addr STORE::xt + CODE + jsr popxr + jsr popwr + jsr _mkdict + sta DLAST+1 + sty DLAST + NEXT +eword + +; Core 6.1.1000 +dword CREATE,"CREATE" + ENTER + .addr MKENTRY::xt + NLIT opJSR + .addr CCOMMA::xt + .addr LIT::xt + .addr pushda + .addr COMMA::xt + EXIT +eword + +; Core ext 6.2.1173 +dword DEFER,"DEFER" + ENTER + .addr MKENTRY::xt + NLIT opJMP + .addr CCOMMA::xt + .addr LIT::xt + .addr _undefined + .addr COMMA::xt + EXIT +eword + +; Core ext 6.2.1177 +dword DEFERAT,"DEFER@" + ENTER + .addr _rJMP::xt + .addr FETCH::xt + EXIT +eword + +; Core 6.1.2500 +dword STATEI,"[",F_CONLY|F_IMMED + lda #$00 + sta ZSTATE + sta ZSTATE+1 + NEXT +eword + +; Core 6.1.2540 +dword STATEC,"]" + ldy #$01 + sty ZSTATE + dey + sty ZSTATE+1 + NEXT +eword + +; Core ext 6.1.1175 +dword DEFERSTO,"DEFER!" + ENTER + .addr _rJMP::xt + .addr STORE::xt + EXIT +eword + +; Core 6.1.0450 +dword COLON,":" + ENTER + .addr MKENTRY::xt + NLIT opJSR + .addr CCOMMA::xt + .addr LIT::xt + .addr enter + .addr COMMA::xt + .addr LAST::xt + NLIT 2 + .addr PLUS::xt + .addr DUP::xt + .addr CFETCH::xt + NLIT F_SMUDG ; smudge it + .addr LOR::xt + .addr SWAP::xt + .addr CSTORE::xt + .addr STATEC::xt + EXIT +eword + +; Core ext 6.2.0455 +; compile an anonymous definition +dword NONAME,":NONAME" + ENTER + .addr HERE::xt + NLIT opJSR + .addr CCOMMA::xt + .word LIT::xt + .addr enter + .addr COMMA::xt + .addr STATEC::xt + EXIT +eword + +; Core 6.1.0460 +dword SEMI,";",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr exit_next +dosemi: .addr LAST::xt + NLIT 2 + .addr PLUS::xt + .addr DUP::xt + .addr CFETCH::xt + NLIT F_SMUDG ; unsmudge it + .addr INVERT::xt + .addr LAND::xt + .addr SWAP::xt + .addr CSTORE::xt + .addr STATEI::xt + EXIT +eword + +; Headerless helper word for DOES> and ;CODE +hword SEMIS,"SEMIS" + ENTER + .addr COMP_LIT::xt + .addr exit_code + .addr _JUMP + .addr SEMI::dosemi +eword + +; Core part of DOES> implementation +; modify the most recent CREATEed definition to jsr +; to the address immediately following whoever +; JSRed to this. +.proc SDOES + pla + clc + adc #$01 + sta ZR + pla + adc #$00 + sta ZR+1 + ldy DLAST + lda DLAST+1 + jsr _code + sta WR+1 + sty WR + ldy #$00 + lda (WR),y + cmp #$20 + bne csmm + iny + lda ZR + sta (WR),y + iny + lda ZR+1 + sta (WR),y + NEXT +csmm: ldy #<-22 ; control structure mismatch + lda #>-22 + jmp _throway +.endproc +controlmm = SDOES::csmm + +; Core 6.1.1250 +; DOES> is... complicated +; when a colon def compiles DOES>, the DOES> closes the definition +; with semis and compiles the following to the word: +; jsr SDOES ( see above ) +; jsr ENTER +; RPLUCK INCR +; and then goes back into compile mode until ; +; this has the effect that when the word containing DOES> is executed +; it replaces the effect of the most recently-defined word (provided it was +; created by CREATE) with new effects, namely the word will push +; it's data address onto the stack and execute the code following DOES> +; e.g. : MKARRAY CREATE CELLS ALLOT DOES> SWAP CELLS + ; +; 2 MKARRAY FOO -> OK +; 0 FOO U. -> 35120 OK +; 1 FOO U. -> 35122 OK +dword DOES,"DOES>",F_CONLY|F_IMMED + ENTER + .addr SEMIS::xt ; close current definition for code + .addr COMP_CLIT::xt + .byte opJSR ; C: jsr + .addr COMP_LIT::xt + .addr SDOES ; C: (jsr) SDOES + .addr COMP_CLIT::xt + .byte opJSR ; C: jsr + .addr COMP_LIT::xt + .addr enter ; C: (jsr) ENTER + .word COMP_LIT::xt + .addr RPLUCK::xt ; C: RPLUCK + .word COMP_LIT::xt + .addr INCR::xt ; C: INCR + NLIT 2 + .addr STATE::xt + .addr STORE::xt + EXIT +eword + +; Core 6.1.1200 +dword DEPTH,"DEPTH" + txa + tay + lda #$00 + PUSHNEXT +eword + +; Core ext 6.2.2030 +dword PICK,"PICK" + jsr popay + sty XR + txa + sec + sbc XR + bcc :+ + stx SPTMP + tax + jsr popay + ldx SPTMP + PUSHNEXT +: jmp stku_err +eword + +; Tools 15.6.1.0220 +; I thought about DEPTH 1- 0 DO I PICK . -1 +LOOP +; but it doesn't save anything +dword DOTS,".S" +.if 1 + ; secondary version, uses pictured numeric output + ; 17 bytes shorter than native + ENTER + NLIT '{' + .addr EMIT::xt + .addr SPACE::xt + .addr DEPTH::xt + .addr DUP::xt + .addr DOT::xt + NLIT ':' + .addr EMIT::xt + .addr SPACE::xt + .addr DUP::xt + .addr _IF::xt + .addr done ; early out for empty stack +lp: .addr DECR::xt + .addr DUP::xt + .addr PtoR::xt + .addr PICK::xt + .addr DOT::xt + .addr RtoP::xt + .addr DUP::xt + .addr _IFFALSE::xt + .addr lp +done: .addr DROP::xt + NLIT '}' + .addr EMIT::xt + EXIT +.else + ; native version, uses DaveX functions + stx SPTMP + jsr xmess + .byte "{ ",$00 + lda #$00 + ldy SPTMP + jsr xprdec_2 + jsr xmess + .byte " : ",$00 + ldx #$00 +lp: cpx SPTMP + bcc :+ + lda #'}' + jsr _emit + NEXT +: ldy PSTKL,x + lda PSTKH,x + bpl :+ + pha + lda #'-' + jsr _emit + pla + jsr _negateay +: stx XR + jsr xprdec_2 + ldx XR + lda #' ' + jsr _emit + inx + jmp lp +.endif +eword +DOTS_xt = DOTS::xt + +; Non-standard, but useful +dword ZEROSP,"0SP" + ldx #$00 + NEXT +eword + +; Exception ext 9.6.2.0670 +dword ABORT,"ABORT" + ENTER + ;.addr ZEROSP::xt + NLIT -1 + .addr THROW::xt + EXIT +eword + +; Non-standard +dword ABORTBANG,"ABORT!",F_IMMED + jmp ABORT::xt +eword + +; headerless word implementing text interpreter +hword INTERPRET,"INTERPRET" +loop: ENTER + .addr INQ::xt ; is there input? + .addr _IF::xt ; ( tf -- ) + .addr done ; done if none + .addr PARSE_NAME::xt ; otherwise parse next word + CODE + jsr popxr + jsr popwr + lda XR+1 + eor XR + beq loop ; if length is 0, loop back + jsr _search + bcc trynum + jsr _code ; get code address & flags + php ; save flags + jsr pushay + plp + bvs conly ; compile-only + bmi execute ; immediate + lda ZSTATE + ora ZSTATE+1 + beq execute +compile: ldy #COMMA::xt + jsr pushay +execute: ENTER + .addr EXECUTE::xt + CODE +lp2: jmp loop +done: EXIT +trynum: jsr _parsenum + bcc badword + jsr pushay + lda ZSTATE + ora ZSTATE+1 + beq lp2 + jsr peekay + ora #$00 + beq compile ; fast literal + ldy #LIT::xt + jsr cworday + jmp compile +badword: ldy #$00 +pr: cpy XR + bcs notfnd + lda (WR),y + jsr _emit + iny + bne pr +notfnd: lda #'?' + jsr _emit + ldy #<-13 + lda #>-13 +barf: jmp _throway +conly: php + lda ZSTATE + ora ZSTATE+1 + bne :+ + plp + dex ; drop xt from stack + ldy #<-14 + lda #>-14 + bne barf +: plp + bmi execute + bpl compile +eword +_undefined = INTERPRET::notfnd + +; Core ext 6.2.2182 +; TODO: if/when file words are implemented, this has to deal with them +; as well, and some words that use it (EVALUATE) will need to be modified +dword SAVEINPUT,"SAVE-INPUT" + ENTER + .addr SOURCE::xt ; put CIB and #IN on stack + .addr PIN::xt + .addr FETCH::xt ; put >IN on stack + NLIT 3 + EXIT +eword + +; Core ext 6.2.2148 +dword RESTOREINPUT,"RESTORE-INPUT" + ENTER + .addr DROP::xt + .addr PIN::xt + .addr STORE::xt + .addr NIN::xt + .addr STORE::xt + .addr CIB::xt + .addr STORE::xt + EXIT +eword + +; Core 6.1.1360 +; Save the current input source to the return stack +; set input up for string to evaluate, then put it all back +dword EVALUATE,"EVALUATE" + ENTER + .addr SOURCEID::xt ; puts one item on stack + .addr SAVEINPUT::xt ; puts n+1 items on stack, with n at the top + .addr INCR::xt ; and add one for source ID + .addr NPtoR::xt ; save on return stack + .addr PtoR::xt ; and save the count on return stack + NLIT -1 + .addr dSOURCEID::xt + .addr STORE::xt ; set source ID to -1 + NLIT 0 + .addr PIN::xt ; set >IN to 0 + .addr STORE::xt + .addr NIN::xt + .addr STORE::xt ; string length to #IN + .addr CIB::xt + .addr STORE::xt ; string addr to CIB + .addr INTERPRET::xt ; interpret from there until nothing left + .addr RtoP::xt ; get count back + .addr NRtoP::xt ; and pull them off the return stack + .addr DECR::xt ; account for what we added + .addr RESTOREINPUT::xt ; restore input spec + .addr dSOURCEID::xt + .addr STORE::xt ; and input source ID + EXIT +eword + +.proc _status + lda SOURCE_ID + ora SOURCE_ID+1 + bne :+ + lda #ACR + jsr _emit +: NEXT +.endproc + +dword STATUS,"STATUS" + jmp _status +eword + +; Core 6.1.2050 +; Empty the return stack, store zero in SOURCE-ID if it is present, make the +; user input device the input source, and enter interpretation state. Do not +; display a message. Repeat the following: +; * Accept a line from the input source into the input buffer, set >IN to zero, +; and interpret. +; * Display the implementation-defined system prompt if in interpretation +; state, all processing has been completed, and no ambiguous condition exists. +dword QUIT,"QUIT" + lda #$00 ; enter interpreting state + sta ZSTATE + sta ZSTATE+1 + stx SPTMP + ldx RSSAV ; clear return stack + txs + ldx SPTMP + jsr _patch ; forget most recent def if smudged + ENTER ; outer interpreter +source0: .addr SETKBD::xt ; set keyboard source +lp: .addr STATUS::xt ; display status (default: CR if source ID=0) + .addr REFILL::xt ; get input (TODO, before this SOURCE-ID should reflect redirection) + .addr _IF::xt ; did we get any? + .addr source0 ; if not, set source to keyboard, go again + .addr INTERPRET::xt ; otherwise, interpret what we got + .addr SOURCEID::xt ; what source? + .addr _IFFALSE::xt ; something other than keyboard? + .addr lp ; yes, don't print any prompts + .addr REDIRECTQ::xt ; I/O redirected? + .addr DROP::xt ; nobody cares about poor output redirection :( + .addr _IFFALSE::xt ; not redirecting? + .addr lp ; we are! don't do prompt + .addr SPACE::xt ; otherwise, a space + .addr _SMART::xt ; compiling? + .addr interp ; no, do normal prompt + SLIT "[OK]" ; otherwise do compiling prompt + .addr TYPE::xt + .addr _JUMP::xt + .addr lp +interp: SLIT "OK" + .addr TYPE::xt + .addr _JUMP::xt + .addr lp +eword +QUIT_xt = QUIT::xt + +; headerless word to do first QUIT when there is a file on the command line +hword FQUIT,"FQUIT" + lda SOURCE_ID ; already have file refnum? + beq :+ ; if not go ahead and set it up + jmp _cold::abort ; otherwise abort +: lda #$00 ; enter interpreting state + sta ZSTATE + sta ZSTATE+1 + ldx RSSAV ; clear return stack + txs + jsr xgetparm_n + jsr xfman_open + bcc :+ + jmp xProDOS_err ; totally bomb if file not available +: sta SOURCE_ID + ldx #$00 ; clear parameter stack + ENTER + .addr TIB::xt + .addr CIB::xt + .addr STORE::xt + .addr _JUMP::xt + .addr QUIT::lp +eword +FQUIT_xt = FQUIT::xt + +; Core 6.1.0080 +dword RPAREN,"(",F_IMMED + ENTER + NLIT ')' + .addr PARSE::xt + EXIT +eword + +; Tools 15.6.1.0600 +dword VIEW,"?" + ENTER + .addr FETCH::xt + .addr DOT::xt + EXIT +eword + +; Core ext 6.2.0200 +dword DOTPAREN,".(",F_IMMED + ENTER + NLIT ')' + .addr PARSE::xt + .addr TYPE::xt + EXIT +eword + +; Davex +dconst CBUFF,"CATBUFF",catbuff +; Davex +dconst FBUFF,"FBUFF",filebuff +; Davex +dconst FBUFF2,"FBUFF2",filebuff2 +; Davex +dconst FBUFF3,"FBUFF3",filebuff3 + +; Davex +dword DOTFTYPE,".FTYPE" + jsr popay + tya + stx SPTMP + jsr xprint_ftype + ldx SPTMP + NEXT +eword + +; Davex +dword DOTACCESS,".ACCESS" + jsr popay + tya + stx SPTMP + jsr xprint_access + ldx SPTMP + NEXT +eword + + +; Davex +dword U3PERCENT,"3U%" + jsr popaxy + sta num+2 + stx num+1 + sty num + ldx SPTMP + jsr popaxy + jsr xpercent + ldx SPTMP + jsr pusha + NEXT +eword + +dword UPERCENT,"U%" + ENTER + .addr TWOStoD::xt + .addr U3PERCENT::xt + EXIT +eword + +; Davex +dword DOTSD,".SD" + jsr popay + tya + stx SPTMP + jsr xprint_sd + ldx SPTMP + NEXT +eword + +; Davex +dword CSTYPE,"CSTYPE" + jsr popay + stx SPTMP + jsr xprint_path + ldx SPTMP + NEXT +eword + +; Davex +dword BUILD_LOCAL,"BUILD_LOCAL" + jsr popay + stx SPTMP + jsr xbuild_local + ldx SPTMP + PUSHNEXT +eword + +; Davex +dword PREDIRECT,"+REDIRECT" + stx SPTMP + lda #$FF +redir: jsr xredirect + ldx SPTMP + NEXT +eword + +; Davex +dword MREDIRECT,"-REDIRECT" + stx SPTMP + lda #$00 + beq PREDIRECT::redir +eword + +; Davex +dword YESNO,"Y/N" + stx SPTMP + jsr xyesno +yn2: beq :+ + lda #$FF +: tay + ldx SPTMP + PUSHNEXT +eword + +; Davex +dword YESNO2,"Y/N2" + jsr popay + tya + stx SPTMP + jsr xyesno2 + jmp YESNO::yn2 +eword + +; Davex +dword BELL,"BELL" + stx SPTMP + jsr xbell + ldx SPTMP + NEXT +eword + +; Davex +dword PRDATE,".DATE" + jsr popay + stx SPTMP + jsr xpr_date_ay + ldx SPTMP + NEXT +eword + +; Davex +dword PRTIME,".TIME" + jsr popay + stx SPTMP + jsr xpr_time_ay + ldx SPTMP + NEXT +eword + +; Davex +.proc dircommon + stx SPTMP + jsr xpush_level + ldx SPTMP + rts +.endproc + +; Davex +dword TDIR,"catbuff +done: PUSHNEXT +: lda #$00 + tay + beq done +eword + +; Davex +dword DIRT,"DIR>" + stx SPTMP + jsr xdir_finish + ldx SPTMP + NEXT +eword + +; Davex +dword CHKWAIT,"WAIT?" + stx SPTMP + jsr xcheck_wait + ldx SPTMP + lda #$00 + bcc :+ + lda #$ff +: tay + PUSHNEXT +eword + +; Davex +dword IOPOLL,"IOPOLL" + jsr xpoll_io ; all regs preserved + NEXT +eword + +; Davex +dword DIRTY,"DIRTY" + stx SPTMP + jsr xdirty + ldx SPTMP + NEXT +eword + +; Davex +dword PRVER,".VER" + jsr popay + tya + stx SPTMP + jsr xprint_ver + ldx SPTMP + NEXT +eword + +; Davex +; ( c -- ay x true ) or ( c -- false ) +dword XINFO,"XINFO" + jsr popay + stx SPTMP + tya + tax + jsr xshell_info + stx XR + ldx SPTMP + bcs bad + sta YR+1 + sty YR + jsr pushay + lda XR + jsr pusha + lda #$FF + bne :+ +bad: lda #$00 +: tay + PUSHNEXT +eword + +.proc xpmgr_do + stx SPTMP + jsr xpmgr +command: .byte $00 +parm1: .word $0000 +parm2: .word $0000 + ldx SPTMP + NEXT +.endproc + +.proc xpmgr_begin + sta xpmgr_do::command + lda #opNOP + sta xpmgr_do::parm2+1 ; for one-parm commands, the common case + sta xpmgr_do::parm2 + jsr _swap + jsr popay + sta xpmgr_do::parm1+1 + sty xpmgr_do::parm1 + rts +.endproc + +; Davex - append one counted string to another +dword CAPPENDS,"CS+CS" + lda #pm_appay + jsr xpmgr_begin + jsr popay + jmp xpmgr_do +eword + +; Davex - append one character to counted string +dword CAPPEND,"CS+" + lda #pm_appch + jsr xpmgr_begin + jsr popay + tya + jmp xpmgr_do +eword + +; Davex - remove path segment +dword CDROP,"CS/-" + lda #pm_up + jsr xpmgr_begin + jmp xpmgr_do +eword + +; Davex - add / if none in string +dword CSLASH,"CS+/" + lda #pm_slashif + jsr xpmgr_begin + jmp xpmgr_do +eword + +; Davex - copy counted string from PARM1 to PARM2 +dword CSMOVE,"CSMOVE" + lda #pm_copy + jsr xpmgr_begin + jsr popay + sta xpmgr_do::parm2+1 + sta xpmgr_do::parm2 + jmp xpmgr_do +eword + +; ProDOS +dword P8MLI,"MLI" + jsr popay + sta parmlist+1 + sty parmlist + jsr popay + sty callnum + stx SPTMP + jsr mli +callnum: .byte $00 +parmlist: .addr $0000 +chkerr1: ldx SPTMP ; other words enter here to restore SP first +chkerr: bcc :+ ; check for error, throw it if present + jmp _throwp8 +: NEXT +eword + +; Core 6.1.0710 +dword ALLOT,"ALLOT" + jsr popay + pha + tya + clc + adc CHERE + sta CHERE + pla + adc CHERE+1 + sta CHERE+1 + NEXT +eword + +; Core ext 6.2.0825 +dword BUFFER,"BUFFER:" + ENTER + .addr CREATE::xt + .addr ALLOT::xt + EXIT +eword + +; Core 6.1.0880 +dword CELLP,"CELL+" + ENTER + NLIT 2 + .addr PLUS::xt + EXIT +eword + +; Core 6.1.0890 +dword CELLS,"CELLS" + ENTER + NLIT 2 + .addr MULT::xt + EXIT +eword + +; Core 6.1.0897 +dword CHARP,"CHAR+" + jmp INCR::xt +eword + +; Core ext 6.2.0945 +; in our case, the semantics of COMPILE, and , +; are the same +dword COMPILEC,"COMPILE," + jmp COMMA::xt +eword + +; Core 6.1.0950 +dword CONSTANT,"CONSTANT" + ENTER + .addr MKENTRY::xt + .addr COMP_CLIT + .byte opJSR + .addr COMP_LIT + .addr pushconst + .addr COMMA::xt ; compile value + EXIT +eword + +; Core ext 6.2.2405 +dword VALUE,"VALUE" + jmp CONSTANT::xt +eword + +; Core ext 6.2.2295 +dword TO,"TO",F_IMMED + ENTER ; interpretation + .addr PARSEFIND::xt + .addr DXT::xt + .addr rBODY::xt + .addr _SMART::xt + .addr interp + .addr COMP_LIT::xt ; compilation semantics + .addr LIT::xt ; compile literal + .addr COMMA::xt ; compile address of VALUE / LOCAL + .addr COMP_LIT::xt ; we get to do a neat trick here +interp: .addr STORE::xt ; and re-use the interpretation store + EXIT +eword + +; Core 6.1.0980 +dword COUNT,"COUNT" + ENTER + .addr DUP::xt + .addr INCR::xt + .addr SWAP::xt + .addr CFETCH::xt + EXIT +eword + +; Core 6.1.1550 +dword WFIND,"FIND" + ENTER + .addr DUP::xt ; ( c-addr -- c-addr c-addr ) + .addr COUNT::xt ; ( c-addr -- c-addr c-addr u ) + .addr DSEARCH::xt ; ( c-addr -- c-addr 0|xt ) + .addr DUP::xt ; ( c-addr 0|xt -- c-addr 0|xt 0|xt ) + .addr _IF::xt ; ( c-addr 0|xt 0|xt -- c-addr 0|xt ) + .addr notfound ; if ( c-addr 0 -- ) + .addr NIP::xt ; otherwise it's ( c-addr xt -- ), drop c-addr + CODE ; do some native work + jsr popay + jsr _code + php + jsr pushay + lda #$00 ; -1 = immediate flag + ldy #$01 + plp + bmi :+ ; yep, immediate + jsr _negateay ; otherwise change to -1 +: jsr pushay ; and push it + NEXT +notfound: EXIT +eword + +; headerless helper to compile a string +hword CSTRING,"CSTRING" + ldy #cbytea + jsr string_op_ay + NEXT +eword + +; swap the current interpretation string buffer +; and return it +hword NEXTSBUF,"NEXTSBUF" + ENTER + .addr CSBUF::xt + .addr FETCH::xt + .addr SBUF1::xt + .addr EQUAL::xt + .addr _IF::xt + .addr gobuf1 + .addr SBUF2::xt + .addr _SKIP::xt ; skip next instruction +gobuf1: .addr SBUF1::xt + .addr DUP::xt + .addr CSBUF::xt + .addr STORE::xt + EXIT +eword + +hword CSCOMM,"CSCOMM" + ENTER + .addr COMP_LIT::xt + .addr _JUMP::xt ; C: _JUMP + .addr HERE::xt ; ( -- a ) resolve address + .addr COMP_LIT::xt + .addr controlmm ; C: (unresolved) + .addr HERE::xt ; ( a -- a b ) + .addr SWAP::xt ; ( a -- b a ) so we can resolve a first + NLIT '"' ; parse delimiter + .addr PARSE::xt ; ( b a -- b a c-addr u ) + EXIT +eword + +; Core ext 6.2.0855 +; need to compile the following sequence: +; _JUMP f:PUSH PUSH +dwordq SQ,"S'",F_IMMED + ENTER + .addr _SMART::xt ; smart word + .addr interp + .addr CSCOMM::xt ; ( ... -- b a c-addr u ) + .addr SWAP::xt ; ( b a c-addr u -- b a u c-addr ) + .addr OVER::xt ; ( ... -- b a u c-addr u ) + .addr CSTRING::xt ; ( ... -- b a u ) compile string into program + .addr SWAP::xt ; ( ... -- b u a ) + .addr HERE::xt ; ( ... -- b u a h ) + .addr SWAP::xt ; ( ... -- b u h a ) + .addr STORE::xt ; ( ... -- b u ) resolve + .addr SWAP::xt ; ( ... -- u b ) compile addr first + .addr COMP_LIT::xt + .addr LIT::xt ; C: LIT + .addr COMMA::xt ; ( ... -- u ) compile b as c-addr + .addr COMP_LIT::xt + .addr LIT::xt ; C: LIT + .addr COMMA::xt ; ( ... -- u ) compile u + EXIT +interp: .addr NEXTSBUF::xt ; go to next string buffer + .addr DUP::xt ; make extra copy + NLIT '"' + .addr PARSE::xt ; ( ... -- c-addr1 caddr1 c-addr2 u ) + .addr PtoR::xt + .addr SWAP::xt + .addr RCOPY::xt + .addr MOVE::xt + .addr RtoP::xt + EXIT +eword + +; Core ext 6.2.0855 +dwordq CQ,"C'",F_IMMED + ENTER + .addr _SMART::xt + .addr interp + .addr CSCOMM::xt ; ( ... -- b a c-addr u ) + .addr DUP::xt ; ( ... -- b a c-addr u u ) + .addr CCOMMA::xt ; ( ... -- b a c-addr u ) compile copy of u + .addr CSTRING::xt ; ( ... -- b a ) compile string into program + .addr HERE::xt ; ( ... -- b a h ) + .addr SWAP::xt ; ( ... -- b h a ) + .addr STORE::xt ; ( ... -- b ) resolve jump + .addr COMP_LIT::xt + .addr LIT::xt ; C: LIT + .addr COMMA::xt ; ( ... -- b ) compile b as c-addr + EXIT +interp: NLIT '"' + .addr PARSE::xt + .addr NEXTSBUF::xt + .addr PLACE::xt + .addr CSBUF::xt + .addr FETCH::xt + EXIT +eword + +; Core 6.1.0190 +; interpretation semantics defined like .( +dwordq DOTQ,".'",F_IMMED + ENTER + .addr _SMART::xt + .addr interp + .addr SQ::xt ; get msg addr on stack + .addr COMP_LIT::xt + .addr TYPE::xt ; display it + EXIT +interp: NLIT '"' + .addr PARSE::xt + .addr TYPE::xt + EXIT +eword + +; word compiled by ABORT", +hword _ABORTQ,"_ABORT'" + ENTER + .addr ROT::xt ; move param after string + .addr _IF::xt + .addr noabort + NLIT CATCH::flag + .addr CFETCH::xt + .addr _IF::xt + .addr dotype ; if catch flag set, do not type + .addr TWODROP::xt + .addr _SKIP::xt +dotype: .addr TYPE::xt + .addr ZEROSP::xt + NLIT -2 + .addr THROW::xt +noabort: .addr TWODROP::xt ; drop string + EXIT +eword + + +; Exception ext 9.6.2.0680 +dwordq ABORTQ,"ABORT'",F_CONLY|F_IMMED + ENTER + .addr SQ::xt ; compile string + .addr COMP_LIT::xt + .addr _ABORTQ::xt + EXIT +eword + +; Core 6.1.1540 +; ( c-addr u char -- ) - fill u chars (bytes) at c-addr with char +dword FILL,"FILL" + jsr popay +fchary: sty char + ldy #func + jsr string_op_ay + NEXT +func: lda #$FF ; self-modified +char = * - 1 + sta (XR),y + rts +eword + +; Core ext 6.2.1350 +dword ERASE,"ERASE" + ldy #$00 + jmp FILL::fchary +eword + +; String 17.6.1.0780 +dword BLANK,"BLANK" + ldy #' ' + jmp FILL::fchary +eword + + +; Core 6.1.1710 +; TODO: de-dup shared code with COLON +; and future COMPILE-ONLY +dword IMMEDIATE,"IMMEDIATE" + ENTER + .addr LAST::xt + NLIT 2 + .addr PLUS::xt + .addr DUP::xt + .addr CFETCH::xt + NLIT F_IMMED + .addr LOR::xt + .addr SWAP::xt + .addr CSTORE::xt + EXIT +eword + +; Core 6.1.1780 +dword LITERAL,"LITERAL",F_CONLY|F_IMMED + jsr peekay + cmp #$00 + beq fastlit + ENTER + .addr COMP_LIT::xt + .addr LIT::xt + .addr COMMA::xt + EXIT +fastlit: jmp COMMA::xt +eword + +; helper function to perform a function in ZR +; XR times +.proc _iter +lp: lda XR + ora XR+1 + bne :+ + rts + lda XR + bne :+ + dec XR+1 +: dec XR + jsr doit + jmp lp +doit: jmp (ZR) +.endproc + +.proc _shiftcom1 + sta ZR+1 + sty ZR + jsr popxr + jsr popwr + jmp _iter +.endproc + +.proc _shiftcom2 + lda WR+1 + ldy WR + PUSHNEXT +.endproc + +; Core 6.1.1805 +dword LSHIFT,"LSHIFT" + ldy #goleft + jsr _shiftcom1 + jmp _shiftcom2 +goleft: asl WR + rol WR+1 + rts +eword + +; Core 6.1.2230 +dword SPACES,"SPACES" + ldy #doit + sta ZR+1 + sty ZR + jsr popxr + jsr _iter + NEXT +doit: lda #' ' + jmp _emit +eword + +; Core 6.1.0330 +dword TWOMULT,"2*" + jsr popwr + jsr LSHIFT::goleft + jmp _shiftcom2 +eword + +; Core 6.1.2162 +dword RSHIFT,"RSHIFT" + ldy #goright + jsr _shiftcom1 + jmp _shiftcom2 +goright: lsr WR+1 + ror WR + rts +eword + +; Core 6.1.0330 +dword TWODIV,"2/" + jsr popwr + jsr RSHIFT::goright + jmp _shiftcom2 +eword + +.proc _marker + ENTER + .addr HERE::xt + .addr LAST::xt + .addr CREATE::xt + .addr COMMA::xt ; compile LAST first + .addr COMMA::xt ; then HERE + CODE + jsr SDOES + ENTER + .addr RPLUCK::xt + .addr INCR::xt + CODE + jsr popwr + ldy #$00 + lda (WR),y + sta DLAST + iny + lda (WR),y + sta DLAST+1 + iny + lda (WR),y + sta CHERE + iny + lda (WR),y + sta CHERE+1 + NEXT +.endproc + +; Core 6.2.1850 +dword MARKER,"MARKER" + jmp _marker +eword + +; Tools 15.6.1.2465 +dword WORDS,"WORDS" + sta SPTMP + lda DLAST + sta WR + lda DLAST+1 + sta WR+1 +lp: lda WR + ora WR+1 + bne :+ +done: lda SPTMP + NEXT +: lda WR+1 + jsr PrByte + lda WR + jsr PrByte + lda #' ' + jsr _emit + ldy #$02 + lda (WR),y + and #$0F + beq nxt + clc + tax +pr: iny + lda (WR),y + jsr _emit + dex + bne pr +nxt: lda #ACR + jsr _emit + jsr xcheck_wait + bcs done + ldy #$00 + lda (WR),y + pha + iny + lda (WR),y + sta WR+1 + pla + sta WR + jmp lp +eword + +; Core 6.1.2033 +dword POSTPONE,"POSTPONE",F_CONLY|F_IMMED + ENTER + .addr PARSEFIND::xt + .addr DXT::xt + .addr COMMA::xt + EXIT +eword + +; Core 6.1.2410 +dword VARIABLE,"VARIABLE" + ENTER + .addr CREATE::xt + NLIT 2 + .addr ALLOT::xt + EXIT +eword + +; Core ext 6.2.2395 +dword UNUSED,"UNUSED" + ENTER + .addr DHIMEM::xt + .addr FETCH::xt + .addr HERE::xt + .addr MINUS::xt + EXIT +eword + +; Core 6.1.2120 +dword RECURSE,"RECURSE",F_CONLY|F_IMMED + ENTER + .word LAST::xt + .word DXT::xt + .word COMMA::xt + EXIT +eword + +; Core 6.1.1880 +dword MIN,"MIN" + ENTER + .word TWODUP::xt + .word SGT::xt +com: .word _IF::xt + .word noswap + .word SWAP::xt +noswap: .word DROP::xt + EXIT +eword + +; Core 6.1.1870 +dword MAX,"MAX" + ENTER + .word TWODUP::xt + .word SLT::xt + .word _JUMP::xt + .word MIN::com +eword + +; Core ext 6.2.2440 +; ( test low high ) true if test is within low (inclusive) and high (exclusive) +; required for loop checks +dword WITHIN,"WITHIN" + ENTER + .addr OVER::xt + .addr MINUS::xt + .addr PtoR::xt + .addr MINUS::xt + .addr RtoP::xt + .addr ULT::xt + EXIT +eword + +; Headerless helper to put the top two stack entries in numeric order +dword ORDER,"ORDER" + ENTER + .addr TWODUP::xt + .addr MAX::xt + .addr PtoR::xt + .addr MIN::xt + .addr RtoP::xt + EXIT +eword + +; and now the do ... loop stuff, here's the architecture: +; a loop is compiled as such +; |_DO _JUMP leave-addr|(1)word word word word|_LOOP|-PLOOP _JUMP (1)| UNLOOP +; where the first group is applied by DO, dropping _JUMP address on the +; stack. Any instance of LEAVE will jump here. leave-addr is resolved when LOOP +; /+LOOP are compiled, which put 1 _PLOOP/_PLOOP, followed by _UNLOOP, with the effect that +; leave jumps to the _JUMP following _DO and +; when executing: +; _DO puts the loop control parameters on the Rstack, and finishes with a jmp +; to _SKIP2 to skip the flow control structure. +; any LEAVE will jump back to the _JUMP, which will jump forward to the UNLOOP +; and finally, _LOOP/_PLOOP will increment/offset the index and compare it to +; the ending value using WITHIN and will either fall through the to the UNLOOP +; or jump back to the beginning of the loop + +; run-time semantics for DO, must be primitive or account for ENTER on rstack +; ( -- limit index )(R: -- leave_address index limit ) +hword _DO,"_DO" + lda IP+1 ; put leave target + pha ; onto the stack + lda IP + pha + jsr popay ; get index + pha + tya + pha + jsr popay ; get limit + pha + tya + pha + jmp _SKIP2::xt ; skip LEAVE's target +eword + +; Core 6.1.1240 +dword DO,"DO",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _DO::xt ; compile execution semantics + .addr HERE::xt ; ( C: -- do-sys ) address for LEAVE + .addr COMP_LIT::xt + .addr _JUMP::xt ; LEAVE will jump here + .addr COMP_LIT::xt + .addr controlmm ; LOOP/+LOOP will jump to do-sys+4, after this word + EXIT +eword + +; Core 6.1.2380 +; Really, it's 3RDROP +dword UNLOOP,"UNLOOP",F_CONLY + pla + pla + pla + pla + pla + pla + NEXT +eword + +; run-time semantics for +LOOP +; with increment on stack and (R: index limit ) +; leaves new loop parms on return stack +; if the new index is in the termination range, +; exits via _SKIP, otherwise exits via _JUMP +; WR: increment +; XR: computed next index +; YR: limit +; ZR: computed limit bounds +hword _PLOOP,"_+LOOP" + jsr popwr ; increment to WR + pla ; get limit from return stack + sta YR ; put limit in YR + clc + adc WR ; add increment to get upper bound low byte + sta ZR ; to put in ZR + pla ; get the high byte + sta YR+1 ; limit in YR + adc WR+1 ; add high byte of increment + sta ZR+1 ; and put in ZR + pla ; now get current index low byte + clc + adc WR ; add increment + sta XR ; new index low byte to XR + pla ; high byte + adc WR+1 ; high byte of increment + sta XR+1 ; into XR + pha ; and new index back on return stack + lda XR ; high byte then low byte + pha + tay ; low byte to Y + lda XR+1 ; high byte to A + jsr pushay ; and put new index on forth stack + lda YR+1 ; finally put limit back on return stack + pha ; high byte + lda YR ; then low byte + pha + tay ; low byte to Y + lda YR+1 ; get high byte + jsr pushay ; and limit on forth stack + lda ZR+1 ; now limit bound into AY + ldy ZR + jsr pushay ; limit bound on forth stack + ENTER + .addr ORDER::xt ; ensure within range is ordered low->high + .addr WITHIN::xt ; ( test lower upper -- flag ) + CODE + jsr popay ; y = FF if within loop term range, $00 if not + tya + beq :+ ; if not within range, go do jump + jmp _SKIP::xt ; otherwise skip +: jmp _JUMP::xt +eword + +; Core 6.1.0140 +; compilation semantics for +LOOP +dword PLOOP,"+LOOP",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .addr _PLOOP::xt + .addr DUP::xt ; dup do-sys + NLIT 4 + .addr PLUS::xt ; get target of loop jump + .addr COMMA::xt ; compile as target of loop + .addr COMP_LIT::xt + .addr UNLOOP::xt ; compile in an UNLOOP (skipped by LEAVE) + NLIT 2 + .addr PLUS::xt ; add 2 to get address we need to resolve + .addr HERE::xt ; we'll set jump to target HERE + .addr SWAP::xt ; get things into position + .addr STORE::xt ; and resolve all LEAVES + EXIT ; whew! +eword + +; Core 6.1.1800 +; compilation semantics for LOOP +dword LOOP,"LOOP",F_IMMED|F_CONLY + ENTER + .addr COMP_LIT::xt + .word 1 + .addr PLOOP::xt + EXIT +eword + +; Core 6.1.1800 +dword LEAVE,"LEAVE",F_CONLY + pla ; drop loop control vars + pla + pla + pla + pla ; get leave address from return stack + tay + pla + jmp _JUMP::go ; and jump +eword + +; Core 6.1.1680 +dword IX,"I",F_CONLY + ENTER + NLIT 2 + .addr RPICK::xt + EXIT +eword + +; Core 6.1.1730 +dword JX,"J",F_CONLY + ENTER + NLIT 4 + .addr RPICK::xt + EXIT +eword + +.if 0 +; non-standard +dword KX,"K",F_CONLY + ENTER + NLIT 6 + .addr RPICK::xt + EXIT +eword +.endif + +; Back to non-loop stuff + +; Core ext 6.2.2535 +dword BACKSLASH,"\",F_IMMED + ENTER + .addr NIN::xt + .addr FETCH::xt + .addr PIN::xt + .addr STORE::xt + EXIT +eword + +; The following words are implemented as no-ops because they are +; inapplicable to this system. They are implemented as JMPs +; so that they can potentially be resolved as deferred words. + +; but first, here's where they will all point initially +hword NO_OP,"NO_OP" + NEXT +eword + +; Core 6.1.0705 +; alignment is not required on this platform +dword ALIGN,"ALIGN" + jmp NO_OP +eword + +; Core 6.1.0706 +; alignment is not required on this platform +dword ALIGNED,"ALIGNED" + jmp NO_OP +eword + +; Core 6.1.0898 +; chars are byte-sized +dword CHARS,"CHARS" + jmp NO_OP +eword + +.proc _environmentq + ENTER + .addr TWODROP::xt + .addr FALSE::xt + EXIT +.endproc + +; Core 6.1.1345 +; ENVIRONMENT? always returns false (unknown) by default +; but implemented as a deferred word +dword ENVIRONMENTQ,"ENVIRONMENT?" + jmp _environmentq +eword + + +; the following words are not implemented per the Forth 2012 standard +; because they are obsolete. They can be enabled if desired. +.if 0 +; Core ext 6.2.2530 +dword CCOMPILE,"[COMPILE]",F_CONLY|F_IMMED + ENTER + .addr FIND::xt + .addr COMMA::xt + EXIT +eword +.endif + + +; must come after all dictionary words +dend + + DX_end \ No newline at end of file diff --git a/dxforth.txt b/dxforth.txt new file mode 100644 index 0000000..36ccf27 --- /dev/null +++ b/dxforth.txt @@ -0,0 +1,467 @@ +THIS DOCUMENT IS A WORK IN PROGRESS + +MG's Davex Forth is a Forth system implementing the Forth 2012 Core word set. + +Additionally, the following are implemented: + +* The Exception word set. +* The following words from the Core Extensions word set: + .( .R U.R 2>R 2R> 2R@ :NONAME AGAIN BUFFER: C" COMPILE, DEFER DEFER! DEFER@ + ERASE FALSE HEX MARKER NIP PAD PARSE PARSE-NAME PICK REFILL + RESTORE-INPUT SAVE-INPUT SOURCE-ID TO TRUE TUCK U> UNUSED VALUE WITHIN \ +* The following words from the Double Number word set: + DABS DNEGATE D. D.R +* The Facility word set. +* The following words from the Programming-Tools word set: + .S ? WORDS +* The following words from the Programming-Tools extension word set: + BYE STATE +* The following words from the String word set: + BLANK +* Words supporting the Apple II+ProDOS+Davex environment (documented below) + +Implementation-defined options (Forth 2012 4.1.1): + + * No address alignment is required for cells or characters. + * EMIT sends non-printing characters to the output device. + * ACCEPT allows all editing that Davex allows, except for history. + * The character set is the Apple II normal character set. + Characters are stored high-bit OFF. + * There are no charater set extensions. + * Control characters match a space character in PARSE-NAME only. + * The control-flow stack is implemented on the parameter stack as addresses + to be resolved later by words that consume them. + * Digits larger than 35 convert to lower-case letters. If BASE is larger + than 35, number parsing becomes case-sensitive. + * After input terminates, the cursor is on the beginning of the next line. + If no exception occurs, after the line is executed, the system will display + the sytem prompt. + * When an exception occurs outside of CATCH, the system will display the + exception number, will forget any current word being defined, and + resume user input through QUIT. + * The input line terminator is the carriage return. + * The maximum size of a counted string is 255 characters. + * The maximum size of a parsed string is limited by memory for PARSE and + PARSE-NAME, and 34 characters for WORD. + * The maximum size of a definition name is 16 characters. + * ENVIRONMENT? never returns anything but false. + * The user input device is the keyboard unless redirected by Davex. + * The user output device is the screen unless redirected by Davex. + * The dictionary starts at 256 bytes beyond the lowest memory allowed by + DaveX and works its way up. + * An address unit contains 8 bits. + * Numbers are 16-bits with the sign (if used) in the high bit. Numbers + are stored little-endian. Arithmetic is 16-bit except for mixed-precision. + No 32-bit by 32-bit division is implemented. + * Ranges: + n: -32768..32767 + +n: 0..32767 + u: 0..65535 + d: -2147483648..2147483647 + +d: 0..2147483647 + ud: 0..4294967295 + * There are no read-only data space regions. + * The buffer for WORD is 35 bytes and is shared with the pictured numeric + output. The buffer will move with the dictionary end. + * One cell is two address units (16 bits total). + * One character is one address unit (8 bits total). + * The keyboard terminal input buffer is 252 bytes. + * The pictured numeric output string buffer is 35 bytes and shared with WORD. + The buffer will move with the dictionary end. + * The size of the PAD is 128 bytes. The PAD will move with the dictionary + end and it usable size will shrink by one byte for each byte that UNUSED is + less than 179. If PAD is used under this circumstance the behavior is + undefined. + * The system is not case-sensitive when finding dictionary names. + * The system prompt is either '[OK]' in the compilation state, or 'OK' in + the interpretation state, and is displayed after the previous input is + evaluated successfully. + * Division rounding is floored by default, but /MOD and M/MOD are deferred + words that may be used to change the rounding of those and their derived + single- and mixed-precision words, respectively. + * STATE takes the value 1 when compiling a definition before any DOES>, + and 2 after DOES>. + * Integer overflow is truncated to the low bits, except in UM/MOD and SM/REM + (and derived operations) where result overthrow results in an exception. + * The current definiton may be found after DOES>. + +Ambiguous conditions (Forth 2012 4.1.2): + +General: + + * When a parsed name is neither a dictionary word nor a number, an exception + is thrown. + * When a definition name exceeds the maximum allowed length, an exception + is thrown. + * When addressing a region not listed in the data space, the system allows + the access with the consequences being left as an exercise for the + programmer. + * Passing incorrect argument types results in the argument being used as if + it were the expected type, possibly causing undefined behavior. + * An execution token may be found for a compile-only word. Executing it + via EXECUTE outside of the compilation context results in undefined + behavior. + * Dividing by zero throws an exception. + * Data stack overflow throws an exception. Return stack overflow results in + undefined behavior. + * Insufficient space for loop-control variables results in undefined behavior. + * Insufficient space in the dictionary results in undefined behavior. + * Interpreting a word with undefined interpretation semantics throws an + exception. + * Modifying the contents of the input buffer may result in undefined behavior. + Modifying the contents of a compiled string literal is allowed but it cannot + be changed in size. The change is permanent within the lifetime of the + program. See below for interpreted string literals. + * Overflowing the pictured numeric string output buffer may collide with the + end of the dictionary. + * Overflowing a parsed string with WORD throws an exception. PARSE and + PARSE-NAME effectively allow any length string to be parsed up to the + end of the the line or input buffer. + * Producing a number out of range results in overflow and truncation of the + result *except* when mixed-precision division overflows an exception is + thrown. + * Data stack undeflow throws an exception. Return stack underflow results in + undefined behavior. + * Unexpected end of the input buffer while parsing a name returns a zero- + length string. + +Specific: + + * >IN past the size of the input buffer results in termination of parsing. + * RECURSE after DOES> results in recursion to the definition being compiled + that contains the DOES>. + * RESTORE-INPUT requires the current input source to be the same that was + used during SAVE-INPUT or undefined behavior results. + * Data space containing definitions may only be de-allocated by a MARKER or + the behavior is undefined. + * No ambiguous conditions result from alignment requirements (there are none). + * The data space pointer cannot be misaligned, alignment is not required. + * PICK with insufficient stack throws an exception. + * Loop control parameters unavailable results in undefined behavior. + * Executing IMMEDIATE affects the last definition with a name. + * TO relies on >BODY, if >BODY cannot be used on the word, an exception is + thrown. That being said, all words defined by CREATE, VALUE, CONSTANT, :, + :NONAME, DEFER and their derivatives have a body. This means that TO may + modify the first execution token within a colon definition. It can also + be used to alter a (non-system) CONSTANT or the target of DEFER. + * When name is not found by POSTPONE, [COMPILE], etc., an exception is thrown + and the current definition being compiled is discarded. + * If parameters are not of the same type in DO, the loop proceeds as if they + were the same type. + * POSTPONE, [COMPILE], etc. applied to TO result in TO's execution token + being compiled, making the word a parsing word. + * WORD is limited to 34 chars + length, which is less than the maximum length + of a counted string. An exception will be thrown if the parsed word exceeds + the maximum. + * If u is greater than the number of bits in a cell for LSHIFT and RSHIFT, + the result will be zero. + * With regards to >BODY and DOES>, all secondary words have a body. DOES> + will alter any secondary unless it was created with DEFER. + * Pictured numeric output words used outside of <# and #>, but before any + <# may write to unintended locations in memory, resulting in undefined + behavior. It is generally safe to use them immediately after the #>, but + the c-addr,u pair returned by #> will no longer be valid. + * Accessing an unassigned deferred word throws an exception. + * Attempting to assign an xt to a word not defined by DEFER throws an + exception, when using DEFER! and derivatives. + * POSTPONE, [COMPILE], etc. used to resolve a deferred word results in + undefined behavior unless the deferred word is declared IMMEDIATE. + * S\" is not implemented, so \x not followed by two hexadecimal digits is + not applicable. + * Similarly, a \ before any character not defined for S\" is not applicable. + +Other system documentation (Forth 2012 4.1.3) + + * No non-standard words use PAD. + * Terminal facilities are the same as those provided by Davex. + * Program space available is about 1.5K. + * The return stack is 128 cells, and is implemented in the 6502 stack. Some + cells are used by the host system software. + * The data stack is 128 cells. The data stack is split, the low unit and + high unit of any cell on the stack are not adjacent in memory. + * The system dictionary space is approximately 8K. + +Non-standard words included: + +COLD ( x1..xn -- ): Restart the interpreter, resetting the dictionary. + +RDROP ( r: x -- ): drop the top of the return stack + +-ROT: rotate the opposite direction as ROT + +LAST: return the address of the last named dictionary entry + +S/REM: explicit towards-zero 16-bit division. + +F/MOD: explicit floored 16-bit division. + +M/MOD: mixed-precision division defaulting to floored behavior. Used for +calculations by other system words, may be changed to towards-zero division +using ' SM/REM ' M/MOD DEFER! + +XKEY ( c1 -- c2 ): use Davex to read a key with c1 as the character under +the cursor. + +MAXLEN ( -- u ): return maximum size that can be requested via ACCEPT. + +X3U. ( d -- ): print an unsigned integer of up to 24 bits, in base 10, via +Davex. + +MESSAGE ( n -- ): prints "Msg #" followed by n. Can be replaced with something +more verbose using DEFER! + +ABORT!: like ABORT but an IMMEDIATE word. + +0SP: empty the parameter stack + +CATBUFF: return Davex CATBUFF address. + +FBUFF, FBUFF2, FBUFF3: return the address of the respected Davex buffer. Each +is 512 bytes. + +.FTYPE (u -- ): Use Davex to print ProDOS file type. + +.ACCESS (u -- ): use Davex to print ProDOS access bits. + +.SD (u -- ): use Davex to print ProDOS slot and drive. + +CSTYPE: use Davex to print a counted string. + +CS+CS ( c-addr1 c-addr2 -- ): append counted string c-addr2 to c-addr1. + +CS+ ( c-addr char -- ): append character char to counted string c-addr + +CS/- ( c-addr -- ): remove ProDOS last path component from counted string + +CS+/ ( c-addr -- ): append a / to counted string c-addr, but only if it does +not already end with one. + +CSMOVE ( c-addr1 c-addr2 ): copy counted string c-addr1 to c-addr2. + +PLACE ( c-addr1 u c-addr2 ): place string described by c-addr,u as a counted +string at c-addr2 + +BUILD_LOCAL (c-addr -- c-addr'): call Davex xbuild_local + +REDIRECT? ( -- f ): Return Davex input or output are redirected, b0=1 if input +b1=1 if output. + ++REDIRECT, -REDIRECT: affect DaveX I/O redirection. + +U% (u1 u2 -- u): use Davex to calculate the percentage of u1 that u2 is. + +3U% (d1 d2 -- u): use Davex to calculate the percentage of d1 that d2 is, up +to 24-bit. + +Y/N ( -- f ): use Davex to ask "? (y/n)" returning true if Y was pressed. + +Y/N2 ( u -- f ): u is either 'y' or 'n'. Perform as Y/N above, but use u as +the default if space or return are pressed. + +BELL: sound the Davex bell as configured by the user. + +.DATE ( u -- ): use Davex to print a ProDOS date word. + +.TIME ( u -- ): use Davex to print a ProDOS time word. + +.P8_ERR ( u -- ): use Davex to print a ProDOS error message. + +: close current directory level and opens the previous one if it was open. +must use this once for each D ( n1 n2 -- d1 d2 ): convert two singles to two doubles + +UML/MOD ( ud u -- u-rem ud-quot): 32/16 division with 32-bit quotient and 16- +bit remainder. + + +Notes for standard words: + +/MOD defaults to floored division but may be changed to towards-zero divion +using ' S/REM ' /MOD DEFER! + +Similarly, M/MOD performs the same function for derived mixed-precision words, +and can be changed via ' SM/REM ' M/MOD DEFER! + +S" and C": In interpretation mode, S" and C" use FBUFF3 (documented above), +split into two 256-byte regions and alternating between the two. I.e. the first +S" or C" uses FBUFF3+0, the second FBUFF3+256, the third back to FBUFF3+0 +again. No effort is made to bounds-check. + + + + +Examples: + +: prname dup c@ 15 and swap 1+ swap type ; +create online_parms 2 c, 0 c, fbuff , +: online 197 online_parms mli 16 0 do 16 i * fbuff + dup c@ dup 15 and if .sd space [char] / emit prname cr else 2drop leave then loop ; +: prent dup dup prname space 16 + c@ .ftype cr ; +: cat ; + +c" /foo" cat + +Implementation internals/Hacking + +This Forth uses the direct-threaded model. Forth is implemented as a virtual +machine that may be freely mixed with with 6502 code. + +The stack would preferably be implemented on the zero page, but Davex does not +give us enough room to have an acceptably-sized stack. Therefore the ZP +contains working registers and system variables instead. This makes the +system slower but somewhat space-efficient with regards to math operations. +Some, if not all, of this slowness is made up for by the direct-threaded model. + +As a direct-threaded Forth, each compiled instruction generally refers +to a code address, not a code field address. The exception is an instruction +in the range $0000..$00FF. Since no code is allowed on the zero page, these +are implemented as fast literal numbers and are immediately pushed onto the +parameter stack. + +The following macros are defined in the source to aid readability: + + ENTER - enter the Forth VM, cells representing compiled Forth code follow + immediately. This starts a new thread by pushing the previous Forth IP + to the stack. This implements the compiled semantics of a colon definition. + + EXIT - exit the current thread and return to the previous thread. + + CODE - exit the current thread and return to native code, which immediately + follows. + + NEXT - used at the end of a primitive to execute the next Forth instruction. + + PUSHNEXT - used at the end of a primitive to optimize the common case of + jsr pushay followed by NEXT. + +The dictionary is implemented as follows: + +No-name (defined by :NONAME for instance) definitions are headerless. and +not searchable. + +Definitions with names are stored in the following format: + + Offset Use + ------- --- + $00-$01 Link to previous named definition, $0000 if this is the last one. + $02 Flags and name length, b7 is always set. + b0-b3 are name length, b4 is the "smudge" bit, b5 is the compile-only + flag, and b6 is the IMMEDIATE flag. + $03-n Name, ASCII with high bit off. + n+1-m Code field, this address is returned by ' (is the execution token). + m+1 Body, for deferred words. + m+3 Body, for colon definitions and CREATEd words. + +Since each code field begins with native code, words defined from within +Forth itself begin with a JSR ($20) or JMP ($4C) opcode. JSR is used for +all definitions except deferred words, which use JMP. + +From an execution token for a named word, the header can be found by scanning +backwards from the xt for the high bit of the flags. + +The compile-only flag is used to flag system words that can only be used +at compilation time, such as looping/control-flow words. This bit may be +used in the future to automatically compile a noname definition in the +interpretation state when such a word is encountered, allowing such words to +be used at any time. For now using words with this flag in the interpretation +state throws an exception. + +The "smudge" bit is used when a definition is open. If the definition is +aborted due to an error, the smudge bit will still be set and the system will +delete the unfinished definition. DOES> resets the smudge bit. + +In the interpreter source code, the following macros are defined to aid +readibility and ensure consistent system dictionary data: + + dsstart - start the dictionary + + dword dname,fname,flags - create a word with the given label, Forth name, and + flags. + + hword dname,fname,flags - create a headerless definiton. fname and flags are + ignored but should be provided so that a headerless word can be changed to + a normal one and vice-versa. + + dwordq dname,fname,flags - as dword, but in the Forth name will have each + ' replaced with a ", required due to an assembler limitation. An equivalent + hwordq is not provided since a headerless word does not have a Forth name. + + dchain dname - change the dictionary chain so the next word will link to + dname instead. + + eword - end a definition started with one of the above. + + dconst dname,fname,value,flags - define a constant with the given value. + This macro results in a primitive that cannot be altered. + + dvar dname,fname,value,flags - define a variable, equivalent to CREATE 1 + CELLS ALLOT. The scoped label val is the address of the value. + + hvar dname,fname,value,flags - as dvar but produce a headerless definition. + + dvalue dname,fname,value,flags - define a VALUE. The scoped label val is + the address of the value. + + hvalue dname,fname,value,flags - define a headerless VALUE. + +All of the definitions produced by the above contain a scoped label, xt, that +is the address used for the execution token of the word, and must be used when +hand-compiling definitions. For instance: + + dword MY2DROP,"MY2DROP" + ENTER + .addr DROP::xt + .addr DROP::xt + EXIT + eword + +dname is the label name to be used for the assembler, and will be used for +hand-compiled Forth code in the interpreter. + +fname is the Forth name, what is used inside the interpreter. + +flags are the flag bits for the word. They are always optional. The high bit +will always be set. + +value is the initial value (variables, values) or set value of the constants. + + + + + + + + + + +