From 451ab143b9cd0db2dba17ffc7bd4c1eb466a9b8b Mon Sep 17 00:00:00 2001 From: Quantum Date: Sun, 24 Nov 2024 23:42:08 -0500 Subject: [PATCH] Initial Commit --- forth.s | 1465 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1465 insertions(+) create mode 100644 forth.s diff --git a/forth.s b/forth.s new file mode 100644 index 0000000..74e4296 --- /dev/null +++ b/forth.s @@ -0,0 +1,1465 @@ +ACIA_CSR equ $EC14 +ACIA_DR equ $EC15 + +F_TRUE equ $FFFF +F_FALSE equ $0000 + +F_R0 equ $E7F0 +F_S0 equ $E6F0 + + + DATA + org $E000 + CODE + org $F000 + + DATA +mul_op_1 + fdb 0 +mul_op_2 + fdb 0 +mul_result + fdb 0 + CODE + +acia_write + pshu A +1 + lda ACIA_CSR + anda #2 + beq 1B + pulu A + sta ACIA_DR + + rts + +acia_read +1 + lda ACIA_CSR + anda #1 + beq 1B + lda ACIA_DR + + rts + +NEXT macro + jmp __NEXT + endm + +__NEXT + ; Load addr of the codeword at X into Y + ldy ,X++ + + ; Dereference codeword and jump + jmp [,Y] + +PUSHRSP macro + pshs \1 + endm + +POPRSP macro + puls \1 + endm + +DOCOL + ; Push old PC + PUSHRSP X + + ; Address of last codeword is still in Y from NEXT + ; Move past codeword (Y+2) + ldb ,Y++ + tfr Y,X + + ; Call NEXT to execute + NEXT + +entry + ; == Init Stack == + ; Board 1 RAM + ; ldu #$7400 + ; lds #$7500 + ; Onboard RAM + ldu #F_S0 + lds #F_R0 + + ; == Init ACIA == + ; Reset + lda #$3 + sta ACIA_CSR + ; CLK / 16 (9600) + ; 8N1 + ; nRTS low, no TX int + ; RX int disabled + lda #$15 + sta ACIA_CSR + + lda #'A' + jsr acia_write + + ; Initialize vars + ldy #0 + sty var_STATE + ldy #10 + sty var_BASE + ldy #name_X + sty var_LATEST + ldy #initial_HERE + sty var_HERE + ldy #F_S0 + sty var_SZ + + ldx #cold_start + NEXT + +cold_start + fdb QUIT + +F_IMMED equ $80 +F_HIDDEN equ $20 +F_LENMASK equ $1F + +link set 0 + +defword macro ; name, namelen, flags, label + align 2 +name_\4 + fdb link +link set name_\4 + fcb \3+\2 + fcc "\1" + align 2 +\4 + fdb DOCOL + endm + +defcode macro ; name, namelen, flags, label + align 2 +name_\4 + fdb link +link set name_\4 + fcb \3+\2 + fcc "\1" + align 2 +\4 + fdb code_\4 +code_\4 + endm + + defcode "DROP",4,0,"DROP" + pulu Y + NEXT + + defcode "SWAP",4,0,"SWAP" + pshu X + ldx 2,U + ldy 4,U + stx 4,U + sty 2,U + pulu X + NEXT + + defcode "DUP",3,0,"DUP" + ldy ,U + pshu Y + NEXT + + defcode "OVER",4,0,"OVER" + ldy 2,U + pshu Y + NEXT + + defcode "ROT",3,0,"ROT" + pshu X + ldx 2,U + ldy 4,U + stx 4,U + ldx 6,U + sty 6,U + stx 2,U + pulu X + NEXT + + defcode "-ROT",4,0,"NROT" + pshu X + ldx 2,U + ldy 6,U + stx 6,U + ldx 4,U + sty 4,U + stx 2,U + pulu X + NEXT + + defcode "2DROP",5,0,"TWODROP" + pulu Y + pulu Y + NEXT + + defcode "2DUP",4,0,"TWODUP" + ldy 2,U + pshu Y + ldy 2,U + pshu Y + NEXT + + defcode "2SWAP",5,0,"TWOSWAP" + pshu X + ldx 2,U + ldy 6,U + stx 6,U + ldx 2,U + ldy 8,U + stx 8,U + sty 4,U + sty 4,U + pulu X + NEXT + + defcode "?DUP",4,0,"QDUP" + ldd ,U + beq 1F + pshu D +1 + NEXT + + defcode "1+",2,0,"INCR" + pulu D + addd #1 + pshu D + NEXT + + defcode "1-",2,0,"DECR" + pulu D + subd #1 + pshu D + NEXT + + defcode "2+",2,0,"INCR2" + pulu D + addd #2 + pshu D + NEXT + + defcode "2-",2,0,"DECR2" + pulu D + subd #2 + pshu D + NEXT + + defcode "+",1,0,"ADD" + pulu D + addd ,U + std ,U + NEXT + + defcode "-",1,0,"SUB" + ldd 2,U + subd ,U + std 2,U + pulu D + NEXT + + defcode "*",1,0,"MUL" + pulu Y + sty mul_op_1 + pulu Y + sty mul_op_2 + jsr _MUL + ldy mul_result + pshu Y + NEXT +ls8 + lslb + rola + lslb + rola + lslb + rola + lslb + rola + lslb + rola + lslb + rola + lslb + rola + lslb + rola + rts +_MUL + lda mul_op_1+1 ; A = op1_L + ldb mul_op_2+1 ; B = op2_L + mul ; D = A * B + std mul_result ; res = D + + lda mul_op_1+0 ; A = op1_H + ldb mul_op_2+1 ; B = op2_L + mul ; D = A*B + ; D << 8... + jsr ls8 + addd mul_result ; D += (D << 8) + std mul_result + + lda mul_op_1+1 ; A = op1_L + ldb mul_op_2+0 ; B = op2_H + mul ; D = A*B + ; D << 8... + jsr ls8 + addd mul_result ; D += (D << 8) + std mul_result + rts + + defcode "/MOD",4,0,"DIVMOD" + ; TODO + NEXT + +do_cmp_pull macro + ; Operands get pulled in the wrong order :( + pulu Y + cmpy ,U + + ; Remove second operand, does not clobber flags + pulu Y + endm + + defcode "=",1,0,"EQU" + do_cmp_pull + beq 1F + ; Not Equal + ldy #F_FALSE + jmp 2F +1 + ; Equal + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "<>",2,0,"NEQU" + do_cmp_pull + bne 1F + ; Equal + ldy #F_FALSE + jmp 2F +1 + ; Not Equal + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "<",1,0,"LT" + do_cmp_pull + bgt 1F + ; Not less than + ldy #F_FALSE + jmp 2F +1 + ; Less than + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode ">",1,0,"GT" + do_cmp_pull + blt 1F + ; Not greater than + ldy #F_FALSE + jmp 2F +1 + ; Greater than + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "<=",2,0,"LE" + do_cmp_pull + bge 1F + ; Not less than + ldy #F_FALSE + jmp 2F +1 + ; Less than + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode ">=",2,0,"GE" + do_cmp_pull + ble 1F + ; Not greater than + ldy #F_FALSE + jmp 2F +1 + ; Greater than + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + +do_cmp0_pull MACRO + ; Load into Y to get flags + ldy ,U + ; Pop off of stack + pulu Y + endm + + defcode "0=",2,0,"ZEQU" + do_cmp0_pull + beq 1F + ; Not equals zero + ldy #F_FALSE + jmp 2F +1 + ; Equals zero + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "0<>",3,0,"ZNEQU" + do_cmp0_pull + bne 1F + ; Equals zero + ldy #F_FALSE + jmp 2F +1 + ; Not equals zero + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "0<",2,0,"ZLT" + do_cmp0_pull + blt 1F + ; Not less than zero + ldy #F_FALSE + jmp 2F +1 + ; Less than zero + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "0>",2,0,"ZGT" + do_cmp0_pull + bgt 1F + ; Not greater than zero + ldy #F_FALSE + jmp 2F +1 + ; Greater than zero + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "0<=",3,0,"ZLE" + do_cmp0_pull + ble 1F + ; Not less than zero + ldy #F_FALSE + jmp 2F +1 + ; Less than zero + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "0>=",3,0,"ZGE" + do_cmp0_pull + bge 1F + ; Not greater than zero + ldy #F_FALSE + jmp 2F +1 + ; Greater than zero + ldy #F_TRUE +2 + ; Push result + pshu Y + NEXT + + defcode "AND",3,0,"AND" + pulu A + anda 1,U + sta 1,U + pulu A + anda 1,U + sta 1,U + NEXT + + defcode "OR",2,0,"OR" + pulu A + ora 1,U + sta 1,U + pulu A + ora 1,U + sta 1,U + NEXT + + defcode "XOR",3,0,"XOR" + pulu A + eora 1,U + sta 1,U + pulu A + eora 1,U + sta 1,U + NEXT + + defcode "INVERT",6,0,"INVERT" + COM 1,U + COM 0,U + NEXT + + defcode "NEGATE",6,0,"NEGATE" + neg 1,U + bcc 1F + inc 0,U +1 ; Handle carry + neg 0,U + NEXT + + defcode "EXIT",4,0,"EXIT" + POPRSP X + NEXT + + defcode "LIT",3,0,"LIT" + ldy ,X++ + pshu Y + NEXT + + defcode "!",1,0,"STORE" + pulu Y ; Address + pulu D ; Data + std ,Y + NEXT + + defcode "@",1,0,"FETCH" + pulu Y + ldy ,Y + pshu Y + NEXT + + defcode "+!",2,0,"ADDSTORE" + pulu Y + pulu D + addd ,Y + std ,Y + NEXT + + defcode "-!",2,0,"SUBSTORE" + pulu Y ; Address + ldd ,Y ; Current value at address + subd ,U ; Amount to subtract from stack + std ,Y + pulu D ; Pop off amount to subtract + NEXT + + defcode "C!",2,0,"STOREBYTE" + pulu Y + pulu D + stb ,Y + NEXT + + defcode "C@",2,0,"FETCHBYTE" + pulu Y + ldb ,Y + lda #0 + pshu D + NEXT + + defcode "C@C!",4,0,"CCOPY" + ldy 2,U ; Src address + lda ,Y + pulu Y ; Dst address + sta ,Y++ + pshu Y ; Dst address + ldy 2,U + lda ,Y++ + sty 2,U + NEXT + + defcode "CMOVE",5,0,"CMOVE" + pulu D ; Length + pulu Y ; Dst address + pshu X ; Preserve PC + ldx 2,U ; Src address + +1 + lda ,X+ + sta ,Y+ + decb + bne 1B + + pulu X ; Restore PC + pulu Y ; Drop src address + NEXT + +defvar macro ; name, namelen, flags, label, initital + defcode \1,\2,\3,\4 + ldy #var_\4 + pshu Y + NEXT + DATA + align 2 +var_\4 + fdb \5 + CODE + endm + + defvar "STATE",5,0,"STATE",0 + defvar "HERE",4,0,"HERE",0 + defvar "LATEST",6,0,"LATEST",name_X + defvar "S0",2,0,"SZ",0 + defvar "BASE",4,0,"BASE",10 + +defconst macro ; name, namelen, flags, label, value + defcode \1,\2,\3,\4 + ldy #\5 + pshu Y + NEXT + endm + + defconst "R0",2,0,"RZ",F_R0 + defconst "DOCOL",5,0,"__DOCOL",DOCOL + defconst "F_IMMED",7,0,"__F_IMMED",F_IMMED + defconst "F_HIDDEN",8,0,"__F_HIDDEN",F_HIDDEN + defconst "F_LENMASK",9,0,"__F_LENMASK",F_LENMASK + + defcode ">R",2,0,"TOR" + pulu Y + PUSHRSP Y + NEXT + + defcode "R>",2,0,"FROMR" + POPRSP Y + pshu Y + NEXT + + defcode "RSP@",4,0,"RSPFETCH" + pshu S + NEXT + + defcode "RSP!",4,0,"RSPSTORE" + pulu S + NEXT + + defcode "RDROP",5,0,"RDROP" + puls Y + NEXT + + defcode "DSP@",4,0,"DSPFETCH" + tfr U,Y + pshu Y + NEXT + + defcode "DSP!",4,0,"DSPSTORE" + pulu Y + tfr Y,U + NEXT + + defcode "KEY",3,0,"KEY" + jsr _KEY + tfr A,B + lda #0 + pshu D + NEXT +_KEY + jsr acia_read + ; Echo + jsr acia_write + rts + + defcode "EMIT",4,0,"EMIT" + pulu D + tfr B,A + jsr _EMIT + NEXT +_EMIT + jsr acia_write + rts + + defcode "WORD",4,0,"WORD" + jsr _WORD + pshu Y ; Address + lda #0 + pshu D ; Length + NEXT + +_WORD +1 + ; Skip spaces + jsr _KEY + ; TODO: Comments + cmpa #' ' + beq 1B + + ldb #0 + ldy #word_bufer +2 + ; Read in word + sta ,Y+ + incb + jsr _KEY + ; Break when key <= 0x20 (lazy search for newline or space) + cmpa #' ' + bhi 2B + + ldy #word_bufer ; Address of word_bufer in Y + ; Length is in B + rts + + DATA + align 2 +word_bufer + rzb 32 + CODE + + defcode "NUMBER",6,0,"NUMBER" + pulu D ; Length + pulu Y ; Address + jsr _NUMBER + pshu Y + lda #0 + pshu D ; Unparsed characers + NEXT + +putc macro + pshu A + lda #\1 + jsr acia_write + pulu A + endm + +_NUMBER + ; Zero out number buffer (steal multiply buffer) + lda #0 + sta mul_op_1+0 + sta mul_op_1+1 + pshu B ; Save counter + ldd var_BASE + std mul_op_2 + pulu B ; Restore counter + + ; Zero length String + tstb + beq 6F + + ; Check for '-' + pshu A + lda ,Y+ + cmpa #'-' + bne 2F + pulu A + lda #1 + pshu A + + ; Decrement count + decb + bne 1F + ; Out of characters + pulu B ; Contains F_TRUE from above, indicating error + rts + +1 + pshu B ; Save counter + jsr _MUL + ; Move result to operand for next loop + ldd mul_result + std mul_op_1 + pulu B ; Restore counter + + ; Load next character into A + lda ,Y+ +2 + ; tolower + cmpa #$60 + blo 3F + anda #$DF + ; Convert char to int +3 + suba #'0' + blo 5F ; Invalid digit + cmpa #10 + blo 4F ; Number + suba #17 ; Alpha + blo 5F ; Invalid digit + adda #10 +4 ; Number + cmpa var_BASE+1 + bge 5F ; Invalid digit + + ; Add digit + adda mul_op_1+1 + sta mul_op_1+1 + lda #0 + adca mul_op_1+0 + sta mul_op_1+0 + + decb ; Decrement count + bne 1B + +5 ; Invalid Digit + ; Negate if first character was '-' + pulu A + tsta + beq 7F + ; Negate + neg mul_op_1+1 + bcc 6F + inc mul_op_1+0 +6 ; Handle carry + neg mul_op_1+0 + +7 ; Invert not needed + ldy mul_op_1 + rts + + defcode "FIND",4,0,"FIND" + pulu D ; Length + pulu Y ; Address + jsr _FIND + pshu Y ; Header of found word or 0 + NEXT + +_FIND + pshu X ; Save IP + ; Length in B + ; Needle in X + tfr Y,X + + ; Current word in Y + ldy var_LATEST +1 + ; Check for end of list (LATEST == 0) + beq 5F + + ; Compare length + lda 2,Y + anda #(F_HIDDEN | F_LENMASK) ; And hidden to make the length not match + ; This useless CPU cant compare registers, use the stack + pshu B + cmpa 0,U + pulu B + bne 4F + + ; Do a strcmp + pshu B,X,Y ; Save lenth and string pointers + ; Skip link + lda ,Y++ + ; Skip length + lda ,Y+ +2 + lda ,Y+ + cmpa ,X+ + bne 3F ; Not equal + decb + bne 2B + ; Equal + pulu B,X,Y ; Restore stack + pulu X ; Restore IP + ; Y still has current word header + rts + +3 + ; Restore stack + pulu B,X,Y +4 + ; Go up a link + ldy ,Y + bra 1B + +5 + ; Not found + ldy #0 + pulu X ; Restore IP + rts + + defcode ">CFA",4,0,"TCFA" + pulu Y ; Word header + jsr _TCFA + pshu Y ; Word CFA + NEXT + +_TCFA + ; Get length + ldb 2,Y + andb #F_LENMASK + + addb #3 ; Add 3 bytes to skip link and length/flags bytes + 1 byte for alignment + + ; Add B to Y + pshu X + tfr Y,X + ABX + tfr X,Y + pulu X + + ; Align to 2 byte boundary + tfr Y,D + addb #1 + adca #0 + andb #~1 + tfr D,Y + + rts + + defword ">DFA",4,0,"TDFA" + fdb TCFA + fdb INCR2 + fdb EXIT + + defcode "CREATE",6,0,"CREATE" + ; Get args + pulu D ; Length (in B) + pulu Y ; Address of name + + pshu X ; Save PC + + pshu Y ; Save name address + ; Store LATEST at HERE + ldy var_LATEST + ldx var_HERE + sty ,X++ + pulu Y ; Restore name address + + ; X has HERE + ; Y has name + ; B has length + + ; Write length + stb ,X+ + + ; Write WORD +1 + lda ,Y+ + sta ,X+ + decb + bne 1B + + ; Align to 2 byte boundary + tfr X,D + addb #1 + adca #0 + andb #~1 + + ; Update LATEST and HERE + ldy var_HERE + sty var_LATEST + std var_HERE + + ; Resetore PC + pulu X + + NEXT + + defcode ",",1,0,"COMMA" + pulu Y + jsr _COMMA + NEXT + +_COMMA + ; Save PC + pshu X + + ldx var_HERE + sty ,X++ + stx var_HERE + + ; Restore PC + pulu X + + rts + + defcode "[",1,F_IMMED,"LBRAC" + ldy #0 + sty var_STATE + NEXT + + defcode "]",1,0,"RBRAC" + ldy #1 + sty var_STATE + NEXT + + defword ":",1,0,"COLON" + fdb WORD + fdb CREATE + fdb __DOCOL, COMMA + fdb LATEST, FETCH, HIDDEN + fdb RBRAC + fdb EXIT + + defword ";",1,F_IMMED,"SEMICOLON" + fdb LIT, EXIT, COMMA + fdb LATEST, FETCH, HIDDEN + fdb LBRAC + fdb EXIT + + defcode "IMMEDIATE",9,F_IMMED,"IMMEDIATE" + ldy var_LATEST + + ; Toggle immediate flag + lda 2,Y + eora #F_IMMED + sta 2,Y + + NEXT + + defcode "HIDDEN",6,0,"HIDDEN" + pulu Y + + ; Toggle immediate flag + lda 2,Y + eora #F_HIDDEN + sta 2,Y + + NEXT + + defword "HIDE",4,0,"HIDE" + fdb WORD + fdb FIND + fdb HIDDEN + fdb EXIT + + defcode "'",1,0,"TICK" + ; Lazy hack to get the next XT in this word + ; ONLY WORKS IN COMPILE + ; Can be impl with WORD FIND >CFA + ldy ,X++ + pshu Y + NEXT + + defcode "BRANCH",6,0,"BRANCH" + tfr X,D + addd ,X + tfr D,X + NEXT + + defcode "0BRANCH",7,0,"ZBRANCH" + do_cmp0_pull + beq code_BRANCH + lda ,X++ + NEXT + + defcode "LITSTRING",9,0,"LITSTRING" + ; Read and skip length + ldy ,X++ + + ; Push address and length + pshu X + pshu Y + + ; Skip string chars + tfr X,D + addd ,U ; Y is pushed above + addb #1 + adca #0 + andb #~1 + tfr D,X + + NEXT + + defcode "TELL",4,0,"TELL" + pulu D ; Length (in B) + pulu Y ; Address +1 + lda ,Y+ + jsr acia_write + decb + bne 1B + NEXT + + defword "QUIT",4,0,"QUIT" + fdb RZ, RSPSTORE + fdb INTERPRET + fdb BRANCH,-4 + + defcode "INTERPRET",9,0,"INTERPRET" + jsr _WORD ; Y = addr, B = length + + lda #0 + sta interpret_is_lit + + pshu B,Y ; Save word + jsr _FIND + cmpy #0 + beq 1F + + ; In the dictionary, check if immediate + ; Y has word header from FIND + pulu D ; Dump saved word, clobbers B + pulu B + lda 2,Y ; Get flags + pshu A + jsr _TCFA + pulu A + ; Y now has the CW of the word + anda #F_IMMED + bne 4F ; Immediate + bra 2F ; Not immediate + +1 + ; Not a word, hopefully a literal + pulu B,Y ; Recover word + inc interpret_is_lit + jsr _NUMBER + tstb + bne 6F ; Not a number + pshu Y ; Save number for later + ldy #LIT ; Codeword to write + +2 + lda var_STATE+1 ; HACK: var_STATE is 16 bit but is only ever 0/1 + beq 4F ; Executing + + ; Compiling + jsr _COMMA + lda interpret_is_lit + beq 3F + ; Literal + ; Pull literal off stack and comma it + pulu Y + jsr _COMMA +3 + NEXT + +4 + ; Executing + lda interpret_is_lit + bne 5F + + ; Not a literal, just jump to XT + jmp [,Y] + +5 + ; Executing a literal, number was already pushed to stack so just call NEXT + NEXT + +6 + ; Parse error + ldb #errmsgend-errmsg + ldy #errmsg +7 + lda ,Y+ + jsr acia_write + decb + bne 7B + NEXT + +errmsg + fcc "ERR!\n" +errmsgend + DATA + align 2 +interpret_is_lit + fcb 0 + CODE + + defcode "CHAR",4,0,"CHAR" + jsr _WORD + ldb ,Y + lda #0 + pshu D + NEXT + + defcode "EXECUTE",7,0,"EXECUTE" + pulu Y + jmp [,Y] + NEXT + + ; FORTH things + defcode ".",1,0,"DOT" + pulu D + jsr w_HEX4 + NEXT +w_HEX1 + anda #$F + cmpa #9 + ble 1F + adda #'A' - '9' - 1 +1 + adda #'0' + jsr acia_write + rts +w_HEX2 + pshu A + lsra + lsra + lsra + lsra + jsr w_HEX1 + pulu A + jsr w_HEX1 + rts +w_HEX4 + jsr w_HEX2 + + tfr B,A + jsr w_HEX2 + rts + + defword "BL",2,0,"BL" + fdb LIT,32 + fdb EXIT + + defword "CR",2,0,"CR" + fdb LIT,10 + fdb EMIT + fdb EXIT + + defword "SPACE",5,0,"SPACE" + fdb LIT,32 + fdb EMIT + fdb EXIT + + defword "LITERAL",7,F_IMMED,"LITERAL" + fdb TICK,LIT,COMMA + fdb COMMA + fdb EXIT + + defword "RECURSE",7,F_IMMED,"RECURSE" + fdb LATEST,FETCH + fdb TCFA + fdb COMMA + fdb EXIT + + defword "IF",2,F_IMMED,"IF" + fdb TICK,ZBRANCH,COMMA + fdb HERE,FETCH + fdb LIT,0,COMMA + fdb EXIT + + defword "THEN",4,F_IMMED,"THEN" + fdb DUP + fdb HERE,FETCH,SWAP,SUB + fdb SWAP,STORE + fdb EXIT + + defword "ELSE",4,F_IMMED,"ELSE" + fdb TICK,BRANCH,COMMA + fdb HERE,FETCH + fdb LIT,0,COMMA + fdb SWAP + fdb DUP + fdb HERE,FETCH,SWAP,SUB + fdb SWAP,STORE + fdb EXIT + + defword "BEGIN",5,F_IMMED,"BEGIN" + fdb HERE,FETCH + fdb EXIT + + defword "UNTIL",5,F_IMMED,"UNTIL" + fdb TICK,ZBRANCH,COMMA + fdb HERE,FETCH,SUB + fdb COMMA + + defword "AGAIN",5,F_IMMED,"AGAIN" + fdb TICK,BRANCH,COMMA + fdb HERE,FETCH,SUB + fdb COMMA + fdb EXIT + + defword "WHILE",5,F_IMMED,"WHILE" + fdb TICK,ZBRANCH,COMMA + fdb HERE,FETCH + fdb LIT,0,COMMA + fdb EXIT + + defword "REPEAT",6,F_IMMED,"REPEAT" + fdb TICK,BRANCH,COMMA + fdb SWAP + fdb HERE,FETCH,SUB,COMMA + fdb DUP + fdb HERE,FETCH,SWAP,SUB + fdb SWAP,STORE + fdb EXIT + + defword "NIP",3,0,"NIP" + fdb SWAP,DROP + fdb EXIT + + defword "TUCK",4,0,"TUCK" + fdb SWAP,OVER + fdb EXIT + + defword "PICK",4,0,"PICK" + fdb INCR + fdb LIT,2,MUL + fdb DSPFETCH,ADD + fdb FETCH + fdb EXIT + + defword ".S",2,0,"DOTS" + fdb DSPFETCH,SZ,FETCH + fdb TWODUP,LT + fdb ZBRANCH,16 + fdb DECR2 + fdb DUP,FETCH,DOT + fdb SPACE + fdb BRANCH,-20 + fdb TWODROP + fdb EXIT + + defword "ID.",3,0,"IDDOT" + fdb INCR2 + fdb DUP,FETCHBYTE + fdb __F_LENMASK,AND + fdb DUP,ZGT ; BEGIN + fdb ZBRANCH,20 + fdb SWAP,INCR + fdb DUP,FETCHBYTE + fdb EMIT + fdb SWAP,DECR + fdb BRANCH,-24 + fdb TWODROP + fdb EXIT + + defword "WORDS",5,0,"WORDS" + fdb LATEST,FETCH + fdb QDUP ; BEGIN + fdb ZBRANCH,14 + fdb DUP,IDDOT + fdb SPACE + fdb FETCH + fdb BRANCH,-16 + fdb CR + fdb EXIT + + defword "CFA>",4,0,"CFAT" + fdb LATEST,FETCH + fdb QDUP ; BEGIN + fdb ZBRANCH,22 + fdb TWODUP,SWAP + fdb LT + fdb ZBRANCH,6 + fdb NIP,EXIT + fdb FETCH ; THEN + fdb BRANCH,-24 + fdb DROP,LIT,0 + fdb EXIT + + defcode "h#",2,0,"HEXNUM" + ldy #16 + sty var_BASE + NEXT + + defcode "d#",2,0,"DECNUM" + ldy #10 + sty var_BASE + NEXT + + defword "DUMPLINE",8,0,"DUMPLINE" + fdb LIT,8 + fdb DUP,ZGT ; BEGIN + fdb ZBRANCH,42 + fdb SWAP,DUP,FETCH,DOT,INCR2,SWAP,DECR,SPACE + fdb DUP,LIT,4,EQU + fdb ZBRANCH,10 + fdb LIT,'|',EMIT,SPACE + fdb BRANCH,-46 + fdb DROP,CR + fdb EXIT + + defword "DUMPLINES",9,0,"DUMPLINES" + fdb DUP,ZGT + fdb ZBRANCH,14 + fdb SWAP,DUMPLINE,SWAP,DECR + fdb BRANCH,-18 + fdb DROP + fdb EXIT + + defword "C,",2,0,"CCOMMA" + fdb HERE,FETCH,STOREBYTE + fdb LIT,1,HERE,ADDSTORE + fdb EXIT + + defword "[COMPILE]",9,F_IMMED,"BRACCOMP" + fdb WORD,FIND,TCFA,COMMA + fdb EXIT + + defword "CONSTANT",8,0,"CONSTANT" + fdb WORD,CREATE + fdb __DOCOL,COMMA + fdb TICK,LIT,COMMA + fdb COMMA + fdb TICK,EXIT,COMMA + fdb EXIT + + defword "ALLOT",5,0,"ALLOT" + fdb HERE,FETCH,SWAP + fdb HERE,ADDSTORE + fdb EXIT + + defcode "CELLS",5,0,"CELLS" + lsl 1,U + rol 0,U + NEXT + + defword "VARIABLE",8,0,"VARIABLE" + fdb LIT,1,CELLS,ALLOT + fdb WORD,CREATE + fdb __DOCOL,COMMA + fdb TICK,LIT,COMMA + fdb COMMA + fdb TICK,EXIT,COMMA + fdb EXIT + + defconst "RAM1",4,0,"RAM1",$0000 + defconst "RAM2",4,0,"RAM2",$2000 + defconst "RAM3",4,0,"RAM3",$4000 + defconst "RAM4",4,0,"RAM4",$6000 + defconst "ROM1",4,0,"ROM1",$8000 + defconst "ROM2",4,0,"ROM2",$A000 + defconst "U28",3,0,"U28",$B000 + defconst "U29",3,0,"U29",$C000 + defconst "U30",3,0,"U30",$D000 + defconst "W13",3,0,"W13",$E000 + defconst "OUTS0",5,0,"OUTS0",$E8E0 + defconst "OUTS1",5,0,"OUTS1",$E8E8 + defconst "PROOFS0",7,0,"PROOFS0",$E8F0 + defconst "PROOFS1",7,0,"PROOFS1",$E8F8 + defconst "IRIG",4,0,"IRIG",$E900 + defconst "HOLD",4,0,"HOLD",$EA00 + defconst "FPI",3,0,"FPI",$EB00 + defconst "CASS",4,0,"CASS",$ED00 + defconst "PRNT",4,0,"PRNT",$ED04 + defconst "FDME",4,0,"FDME",$EE00 + defconst "INTC",4,0,"INTC",$EF00 + defconst "U27",3,0,"U27",$F000 + + defcode "X",1,0,"X" + + DATA +initial_HERE + fcb 0 + CODE + +; == Vectors == + org $fff0 + fdb entry + fdb entry + fdb entry + fdb entry + fdb entry + fdb entry + fdb entry + fdb entry