NEW AUTO 3,1 *-------------------------------------- KW.Lookup >LDYA L.KEYWORDS >STYA ZPPtr1 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 inx lda (ZPPtr1) Array Ending 0, lookup failed bne .1 .9 sec rts .7 iny lda (ZPCLBufPtr),y Get Src text char... beq .9 end of text jmp IsSpaceOrCR CS=end of valid chars *-------------------------------------- KW.mDUP lda (pStack) ldy #1 ora (pStack),y bne KW.DUP clc rts *-------------------------------------- KW.DUP lda pStack beq .9 cmp #$FF bcs .9 cmp #2 bcc .99 ldy #1 lda (pStack),y >PUSHA lda (pStack),y >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 jsr CheckStackPop4 bcs .9 cmp #2 bcc .99 ldy #3 lda (pStack),y >PUSHA lda (pStack),y >PUSHA clc rts .99 lda #E.STKOVERFLOW sec .9 rts *-------------------------------------- KW.ROT lda pStack beq .9 cmp #$FB bcs .9 ldy #5 lda (pStack),y n1 HI pha dey lda (pStack),y n1 LO pha .1 dey lda (pStack),y iny iny sta (pStack),y dey dey bne .1 iny pla sta (pStack) pla sta (pStack),y clc rts .9 lda #E.STACKERROR sec rts *-------------------------------------- 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) 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) 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 ZPOutputBufPtr clc rts KW.ALLOT.9 lda #E.STACKERROR sec rts *-------------------------------------- KW.ALLOT lda #SYM.T.VAR sta ZPType lda pStack beq KW.ALLOT.9 cmp #$FF bcs KW.ALLOT.9 >PUSHB.G hSList >PUSHW ZPCLBufPtr >SYSCALL SListNewKey bcs .9 >STYA ZPKeyID txa jsr NextKW >LDYA ZPDataPtr >STYA ZPAddrPtr >PULLA clc adc ZPDataPtr sta ZPDataPtr >PULLA adc ZPDataPtr+1 sta ZPDataPtr+1 >PUSHB.G hSList >PUSHW ZPKeyID >PUSHWI ZPType >PUSHWI 4 >SYSCALL SListAddData .9 rts *-------------------------------------- KW.nCOMPILE KW.QUOTE KW.FORGET KW.DEFINITIONS KW.VOCABULARY KW.FORTH KW.EDITOR KW.ASSEMBLER lda #E.SYN sec rts *-------------------------------------- KW.VLIST bit bCompile bpl .10 .8 clc .9 rts .10 stz ZPPtr2 stz ZPPtr2+1 .1 >LDYA ZPPtr2 >STYA ZPPtr1 >PUSHB.G hSList >PUSHW ZPPtr1 >PUSHW ZPOutputBufPtr >SYSCALL SListGetByID bcs .8 >STYA ZPPtr2 Save Next ID >PUSHB.G hSList >PUSHW ZPPtr1 KeyID >PUSHW ZPType >PUSHWI 4 >PUSHWZ from Start >SYSCALL SListGetData bcs .9 >PUSHW L.MSG.DUMP2 >PUSHW ZPOutputBufPtr ldx #4 bit ZPType bmi .2 dex dex bvs .2 dex dex .2 >PUSHW L.MSG.TYPES,x >PUSHW ZPAddrPtr >PUSHBI 6 >SYSCALL PrintF jmp .1 KW.VC.9 lda #E.STACKERROR sec rts *-------------------------------------- KW.VARIABLE lda #SYM.T.VAR bra KM.VC *-------------------------------------- KW.CONSTANT lda #SYM.T.CONST KM.VC sta ZPType lda pStack beq KW.VC.9 cmp #$FF bcs KW.VC.9 >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 CP.Emit.Byte stz bCompile clc rts *-------------------------------------- KW.ACODE *-------------------------------------- KW.FCODE lda #E.SYN sec rts *-------------------------------------- MAN SAVE usr/src/bin/forth.s.kw LOAD usr/src/bin/forth.s ASM