NEW AUTO 3,1 *-------------------------------------- KW.Lookup >LDYA L.KEYWORDS >STYA ZPPtr1 >LDYA ZPCLBufPtr >STYA ZPPtr2 ldx #0 .1 ldy #$ff .2 jsr .7 get next valid char in src text bcs .3 .20 jsr ToUpperCase eor (ZPPtr1),y match table char ? asl compare only 7 bits bne .4 no match...get next table keyword bcc .2 not last char in this keyword jsr .7 next char in text... bcc .4 valid....failed .8 tya Keyword Len jsr NextKW clc rts .3 dey lda (ZPPtr1),y was last char in this keyword ? bmi .8 iny .41 jsr IncPtr1 skip chars to next keyword .4 lda (ZPPtr1) bpl .41 jsr IncPtr1 .6 inx lda (ZPPtr1) Array Ending 0, lookup failed bne .1 .9 sec rts .7 iny lda (ZPPtr2),y Get Src text char... beq .9 end of text jmp IsSpaceOrCR CS=end of valid chars *-------------------------------------- KW.DUP lda pStack beq .9 cmp #$FF beq .9 cmp #1 bcc .99 lda (pStack) tax ldy #1 lda (pStack),y >PUSHA txa >PUSHA clc rts .9 lda #E.STACKERROR sec rts .99 lda #E.STKOVERFLOW sec rts *-------------------------------------- KW.DROP lda pStack beq .9 inc pStack beq .9 inc pStack clc rts .9 lda #E.STACKERROR sec rts *-------------------------------------- KW.SWAP ldy #3 lda (pStack),y pha dey #2 lda (pStack),y pha lda (pStack) tax pla sta (pStack) txa sta (pStack),y #2 dey #1 lda (pStack),y tax pla sta (pStack),y iny iny #3 txa sta (pStack),y clc rts *-------------------------------------- KW.OVER lda pStack sec sbc #2 bcc .9 ldy #3 lda (pStack),y >PUSHA lda (pStack),y >PUSHA clc rts .9 lda #E.STKOVERFLOW sec rts *-------------------------------------- KW.ROT *-------------------------------------- KW.mDUP *-------------------------------------- KW.gR *-------------------------------------- KW.Rg *-------------------------------------- KW.R lda #E.SYN sec rts *-------------------------------------- KW.Add jsr CheckStackPop4 bcs .9 clc ldy #2 lda (pStack),y adc (pStack) sta (pStack),y inc pStack lda (pStack),y adc (pStack) sta (pStack),y inc pStack clc .9 rts *-------------------------------------- KW.DAdd >FPU ADD32 clc rts *-------------------------------------- KW.Sub jsr CheckStackPop4 bcs .9 sec ldy #2 lda (pStack),y sbc (pStack) sta (pStack),y inc pStack lda (pStack),y sbc (pStack) sta (pStack),y inc pStack clc .9 rts *-------------------------------------- KW.Mul jsr CheckStackPop4 bcs .9 jsr KW.GetPtr1Ptr2Sign stz ZPPtr3 stz ZPPtr3+1 ldx #16 .1 lsr ZPPtr2+1 ror ZPPtr2 bcc .2 clc lda ZPPtr1 adc ZPPtr3 sta ZPPtr3 lda ZPPtr1+1 adc ZPPtr3+1 sta ZPPtr3+1 .2 asl ZPPtr1 rol ZPPtr1+1 dex bne .1 >LDYA ZPPtr3 jsr KW.PushWSigned clc .9 rts *-------------------------------------- KW.Div jsr KW.DivMoD.1 bcs .9 >LDYA ZPPtr2 jsr KW.PushWSigned clc .9 rts *-------------------------------------- KW.Mod jsr KW.DivMoD.1 bcs .9 >PUSHW ZPPtr3 .9 rts *-------------------------------------- KW.DivMod jsr KW.DivMoD.1 bcs .9 >PUSHW ZPPtr3 >LDYA ZPPtr2 jsr KW.PushWSigned clc .9 rts *-------------------------------------- KW.MulDivMod *-------------------------------------- KW.MulDiv lda #E.SYN sec rts *-------------------------------------- KW.DivMoD.1 jsr CheckStackPop4 bcs .9 jsr KW.GetPtr1Ptr2Sign stz ZPPtr3 stz ZPPtr3+1 ldx #16 .1 asl ZPPtr2 rol ZPPtr2+1 rol ZPPtr3 rol ZPPtr3+1 sec lda ZPPtr3 sbc ZPPtr1 pha lda ZPPtr3+1 sbc ZPPtr1+1 bcs .2 pla dex bne .1 bra .8 .2 sta ZPPtr3+1 pla sta ZPPtr3 inc ZPPtr2 dex bne .1 .8 clc .9 rts *-------------------------------------- KW.GetPtr1Ptr2Sign >PULLW ZPPtr1 sta Sign asl bcc .1 lda ZPPtr1 clc eor #$ff adc #1 sta ZPPtr1 lda ZPPtr1+1 eor #$ff adc #0 sta ZPPtr1+1 .1 >PULLW ZPPtr2 asl bcc .8 lda ZPPtr2 clc eor #$ff adc #1 sta ZPPtr2 lda ZPPtr2+1 eor #$ff adc #0 sta ZPPtr2+1 lda Sign eor #$80 sta Sign .8 rts *-------------------------------------- KW.PushWSigned bit Sign bpl .8 pha tya clc eor #$ff adc #1 tay pla eor #$ff adc #0 .8 >PUSHYA rts *-------------------------------------- KW.MAX jsr CheckStackPop4 bcs .9 lda (pStack) LO ldy #2 cmp (pStack),y dey #1 lda (pStack),y HI iny iny #3 sbc (pStack),y bcc .1 jsr KW.SWAP .1 jmp KW.DROP .9 rts *-------------------------------------- KW.MIN jsr CheckStackPop4 bcs .9 lda (pStack) LO ldy #2 cmp (pStack),y dey #1 lda (pStack),y HI iny iny #3 sbc (pStack),y bcs .1 jsr KW.SWAP .1 jmp KW.DROP .9 rts *-------------------------------------- KW.ABS ldy #1 lda (pStack),y HI bpl .8 lda (pStack) clc eor #$ff adc #1 sta (pStack) lda (pStack),y eor #$ff adc #0 sta (pStack),y .8 clc rts *-------------------------------------- KW.DABS lda #E.SYN sec rts *-------------------------------------- KW.MINUS lda (pStack) LO eor #$ff sec adc #0 sta (pStack) ldy #1 lda (pStack),y HI eor #$ff adc #0 sta (pStack),y clc rts *-------------------------------------- KW.DMINUS lda (pStack) LO eor #$ff sec adc #0 sta (pStack) ldy #1 lda (pStack),y HI eor #$ff adc #0 sta (pStack),y iny lda (pStack),y eor #$ff adc #0 sta (pStack),y iny lda (pStack),y eor #$ff adc #0 sta (pStack),y clc rts *-------------------------------------- KW.AND jsr CheckStackPop4 bcs .9 ldy #2 lda (pStack),y and (pStack) sta (pStack),y inc pStack lda (pStack),y and (pStack) sta (pStack),y inc pStack clc .9 rts *-------------------------------------- KW.OR jsr CheckStackPop4 bcs .9 ldy #2 lda (pStack),y ora (pStack) sta (pStack),y inc pStack lda (pStack),y ora (pStack) sta (pStack),y inc pStack clc .9 rts *-------------------------------------- KW.XOR jsr CheckStackPop4 bcs .9 ldy #2 lda (pStack),y eor (pStack) sta (pStack),y inc pStack lda (pStack),y eor (pStack) sta (pStack),y inc pStack clc .9 rts *-------------------------------------- KW.LWR jsr CheckStackPop4 bcs .9 ldy #2 lda (pStack),y cmp (pStack) inc pStack lda (pStack),y sbc (pStack),y inc pStack ror lda #0 sta (pStack) ldy #1 sta (pStack),y clc .9 rts *-------------------------------------- KW.GTR jsr CheckStackPop4 bcs .9 ldy #2 lda (pStack),y cmp (pStack) inc pStack lda (pStack),y sbc (pStack),y inc pStack lda #0 ror eor #$80 sta (pStack) ldy #1 sta (pStack),y clc .9 rts *-------------------------------------- KW.EQ jsr CheckStackPop4 bcs .9 ldy #2 lda (pStack),y sec sbc (pStack) tax inc pStack lda (pStack),y sbc (pStack) inc pStack tay bne .1 txa bne .1 sec .HS 90 BCC .1 clc lda #0 sbc #0 sta (pStack) ldy #1 sta (pStack),y clc .9 rts *-------------------------------------- KW.NEGATIVE ldy #1 lda (pStack),y asl lda #0 ror sta (pStack) sta (pStack),y clc rts *-------------------------------------- KW.ZERO clc ldy #1 lda (pStack),y ora (pStack) bne .9 sec .9 lda #0 ror sta (pStack) sta (pStack),y clc rts *-------------------------------------- KW.. jsr KW.DUP bcs .9 ldy #2 lda L.FMT.int16 sta (pStack),y iny lda L.FMT.int16+1 sta (pStack),y >PUSHBI 2 >SYSCALL PrintF * clc .9 rts *-------------------------------------- KW..R *-------------------------------------- KW.D. *-------------------------------------- KW.D.R lda #E.SYN sec rts *-------------------------------------- KW.CR >PUSHW L.MSG.ECHOCRLF >PUSHBI 0 >SYSCALL PrintF rts *-------------------------------------- KW.SPACE lda #C.SPACE >SYSCALL PutChar rts *-------------------------------------- KW.SPACES >PULLA beq .8 .1 dec pha lda #C.SPACE >SYSCALL PutChar pla bne .1 .8 clc rts *-------------------------------------- KW.PRINT >LDYAI 256 >SYSCALL GetMem bcs .9 >STYA ZPPtr1 phx ldy #$ff clc .1 iny lda (ZPCLBufPtr),y beq .2 sta (ZPPtr1),y eor #'" bne .1 sec .2 sta (ZPPtr1),y tya adc ZPCLBufPtr sta ZPCLBufPtr bcc .3 inc ZPCLBufPtr+1 .3 >LDYA ZPPtr1 >SYSCALL PutS pla >SYSCALL freemem .9 rts *-------------------------------------- KW.DUMP *-------------------------------------- KW.TYPE *-------------------------------------- KW.COUNT *-------------------------------------- KW.TERMINAL lda #E.SYN sec rts *-------------------------------------- KW.KEY >SYSCALL GetChar bcs .9 >PUSHA .9 rts *-------------------------------------- KW.EMIT >PULLA >SYSCALL PutChar rts *-------------------------------------- KW.EXPECT *-------------------------------------- KW.WORD *-------------------------------------- KW.NUMBER *-------------------------------------- KW.STARTSTR *-------------------------------------- KW.STRADD *-------------------------------------- KW.STRDBL *-------------------------------------- KW.SIGN *-------------------------------------- KW.ENDSTR *-------------------------------------- KW.HOLD *-------------------------------------- KW.DECIMAL *-------------------------------------- KW.HEX *-------------------------------------- KW.OCTAL lda #E.SYN sec rts *-------------------------------------- KW.FETCHW lda (pStack) sta ZPAddrPtr ldy #1 lda (pStack),y sta ZPAddrPtr+1 lda (ZPAddrPtr) sta (pStack) lda (ZPAddrPtr),y sta (pStack),y clc rts *-------------------------------------- KW.STOREW jsr CheckStackPop4 bcs .9 >PULLW ZPAddrPtr >PULLA sta (ZPAddrPtr) >PULLA ldy #1 sta (ZPAddrPtr),y * clc .9 rts *-------------------------------------- KW.FETCHB >PULLW ZPAddrPtr lda (ZPAddrPtr) >PUSHA clc rts *-------------------------------------- KW.STOREB >PULLW ZPAddrPtr >PULLA sta (ZPAddrPtr) clc KW.STOREB.RTS rts *-------------------------------------- KW.FETCHPRINTW jsr KW.FETCHW bcs KW.STOREB.RTS jmp KW.. *-------------------------------------- KW.ADDTOW jsr KW.FETCHW bcs KW.STOREB.RTS jsr KW.Add bcs KW.STOREB.RTS jmp KW.STOREW *-------------------------------------- KW.CMOVE lda #E.SYN sec rts *-------------------------------------- KW.FILL >PULLA bra KW.FILL2 KW.ERASE lda #0 bra KW.FILL2 KW.BLANKS lda #C.SPACE KW.FILL2 tax >PULLA tay >PULLW ZPAddrPtr txa .1 dey sta (ZPAddrPtr),y cpy #0 bne .1 clc rts *-------------------------------------- KW.HERE >PUSHW ZPDataPtr clc rts *-------------------------------------- KW.PAD >PUSHW ZPOutputPtr clc rts *-------------------------------------- KW.ALLOT KW.nCOMPILE KW.QUOTE KW.FORGET KW.DEFINITIONS KW.VOCABULARY KW.FORTH KW.EDITOR KW.ASSEMBLER lda #E.SYN sec rts *-------------------------------------- KW.VLIST clc rts *-------------------------------------- KW.VARIABLE lda #SYM.T.VAR bra KM.VC *-------------------------------------- KW.CONSTANT lda #SYM.T.CONST KM.VC sta ZPType lda pStack cmp #$FE bcs .10 lda #E.STACKERROR sec rts .10 >PUSHB.G hSList >PUSHW ZPCLBufPtr >SYSCALL SListNewKey bcs .9 >STYA ZPKeyID txa jsr NextKW bit ZPType bvs .1 >PULLW ZPAddrPtr bra .2 .1 >PULLA sta (ZPDataPtr) >PULLA ldy #1 sta (ZPDataPtr),y >LDYA ZPDataPtr >STYA ZPAddrPtr lda ZPDataPtr clc adc #2 sta ZPDataPtr bcc .2 inc ZPDataPtr+1 .2 >PUSHB.G hSList >PUSHW ZPKeyID >PUSHWI ZPType >PUSHWI 4 >SYSCALL SListAddData .9 rts *-------------------------------------- KW.BCOLON bit bCompile bmi KW.COLON.SYN >PUSHB.G hSList >PUSHW ZPCLBufPtr >SYSCALL SListNewKey bcs .9 >STYA ZPKeyID txa jsr NextKW lda #SYM.T.CODE sta ZPType >LDYA ZPCodePtr >STYA ZPAddrPtr >PUSHB.G hSList >PUSHW ZPKeyID >PUSHWI ZPType >PUSHWI 4 >SYSCALL SListAddData bcs .9 sec ror bCompile clc .9 rts KW.COLON.SYN lda #E.SYN sec rts *-------------------------------------- KW.ECOLON bit bCompile bpl KW.COLON.SYN lda #$60 jsr EmitByte stz bCompile clc rts *-------------------------------------- KW.ACODE *-------------------------------------- KW.FCODE lda #E.SYN sec rts *-------------------------------------- KW.DO tsx lda $101,x clc adc #0 pha lda $102,x adc #0 ldy RP sta (pData),y dey pla sta (pData),y dey >PULLA start tax >PULLA sta (pData),y dey txa sta (pData),y dey >PULLA end+1 tax >PULLA sta (pData),y dey txa sta (pData),y dey sty RP clc rts *-------------------------------------- KW.LOOP lda #1 ldx #0 KW.LOOPax ldy RP iny end+1 iny iny start clc adc (pData),y sta (pData),y pha iny txa adc (pData),y sta (pData),y tax pla ldy RP iny end+1 cmp (pData),y txa iny sbc (pData),y bcs .8 lda RP clc adc #5 tay lda (pData),y sta ZPPtr1 iny lda (pData),y sta ZPPtr1+1 pla pla jmp (ZPPtr1) .8 lda RP clc adc #6 sta RP * clc rts *-------------------------------------- PW.pLOOP >PULLA tax >PULLA bra KW.LOOPax *-------------------------------------- KW.I ldy RP iny end+1 iny iny start lda (pData),y tax iny lda (pData),y >PUSHA txa >PUSHA clc rts *-------------------------------------- KW.LEAVE *-------------------------------------- KW.IF *-------------------------------------- KW.ELSE *-------------------------------------- KW.ENDIF *-------------------------------------- KW.BEGIN *-------------------------------------- KW.UNTIL *-------------------------------------- KW.REPEAT *-------------------------------------- KW.WHILE lda #E.SYN sec rts *-------------------------------------- MAN SAVE usr/src/bin/forth.s.kw LOAD usr/src/bin/forth.s ASM