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.INVALID lda #E.CSYN sec rts *-------------------------------------- KW.qDUP 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.Add jsr CheckStackPop4 bcs .9 >FPU iADD clc .9 rts *-------------------------------------- KW.DAdd >FPU lADD clc rts *-------------------------------------- KW.Sub jsr CheckStackPop4 bcs .9 >FPU iSUB clc .9 rts *-------------------------------------- KW.DSub >FPU lSUB clc rts *-------------------------------------- KW.Mul jsr CheckStackPop4 bcs .9 >FPU iMUL 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 KW.NEGATE.8 *-------------------------------------- KW.NEGATE lda (pStack) LO eor #$ff sec adc #0 sta (pStack) ldy #1 lda (pStack),y HI eor #$ff adc #0 sta (pStack),y KW.NEGATE.8 clc rts *-------------------------------------- KW.DABS ldy #3 lda (pStack),y HI bpl KW.DNEGATE.8 *-------------------------------------- KW.DNEGATE 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 KW.DNEGATE.8 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 inc pStack lda #0 ror eor #$80 sta (pStack) * 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 inc pStack lda #0 ror sta (pStack) * clc .9 rts *-------------------------------------- * : TL BEGIN DUP . 1 - DUP 0 = UNTIL ; *-------------------------------------- KW.EQ jsr CheckStackPop4 bcs .9 * clc ldy #2 lda (pStack),y eor (pStack) inc pStack tax bne .1 lda (pStack),y eor (pStack) bne .1 sec .1 lda #0 ror inc pStack inc pStack sta (pStack) * clc .9 rts *-------------------------------------- KW.NEGATIVE inc pStack clc rts *-------------------------------------- KW.ZERO clc >PULLA ora (pStack) bne .9 sec .9 lda #0 ror sta (pStack) * 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.U. jsr KW.DUP bcs .9 ldy #2 lda L.FMT.uint16 sta (pStack),y iny lda L.FMT.uint16+1 sta (pStack),y >PUSHBI 2 >SYSCALL PrintF * clc .9 rts *-------------------------------------- KW..R lda #E.SYN sec rts *-------------------------------------- KW.D. >PUSHW L.FMT.int32 ldy #5 ldx #4 .1 lda (pStack),y >PUSHA dex bne .1 >PUSHBI 4 >SYSCALL PrintF >RET 4 *-------------------------------------- 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.KEY >SYSCALL GetChar bcs .9 >PUSHA .9 rts *-------------------------------------- KW.EMIT >PULLA >SYSCALL PutChar rts *-------------------------------------- KW.EXPECT >PULLW ZPPtr1 n >PULLW ZPAddrPtr lda ZPPtr1+1 bmi .8 n < 0, no action eor #$ff sta ZPPtr1+1 lda ZPPtr1 eor #$ff sta ZPPtr1 ldy #0 .1 inc ZPPtr1 bne .2 inc ZPPtr1+1 beq .6 .2 phy >SYSCALL GetChar ply cmp #C.CR beq .7 phy pha >SYSCALL PutChar pla ply iny sta (ZPAddrPtr),y bra .1 .6 tya beq .8 sta (ZPAddrPtr) .7 lda #0 sta (ZPAddrPtr),y .8 clc rts *-------------------------------------- KW.COUNT lda (pStack) sta ZPAddrPtr sec adc #0 sta (pStack) ldy #1 lda (pStack),y sta ZPAddrPtr+1 adc #0 sta (pStack),y lda #0 >PUSHA lda (ZPAddrPtr) >PUSHA clc rts *-------------------------------------- KW.TYPE >PULLW ZPPtr1 n >PULLW ZPAddrPtr ldy #$ff .1 iny lda (ZPAddrPtr),y bne .1 cpy ZPPtr1 bcs .8 iny lda (ZPAddrPtr),y pha lda #0 sta (ZPAddrPtr),y jsr .8 pla sta (ZPAddrPtr),y clc rts .8 ldy #S.PS.hStdOut lda (pPS),y >PUSHA >PUSHW ZPAddrPtr >SYSCALL FPutS clc rts *-------------------------------------- KW.WORD *-------------------------------------- KW.DUMP lda #E.SYN sec rts *-------------------------------------- KW.TERMINAL lda #E.SYN sec rts *-------------------------------------- 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.FETCHSP lda pStack+1 ldy pStack bne .1 inc .1 >PUSHYA clc 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 stz ZPPtr1 lda #1 sta ZPPtr1+1 .1 >LDYA ZPPtr1 >STYA ZPKeyID >PUSHB.G hSList >PUSHW ZPKeyID >PUSHW ZPOutputBufPtr >SYSCALL SListGetByID bcs .8 >STYA ZPPtr1 Save Next ID jsr CS.RUN.GetSymbolData 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 .8 clc .9 rts 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 >PUSHWI 0 ScopeID >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 >PUSHB.G hSList >PUSHW ZPCLBufPtr >PUSHWI 0 ScopeID >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.ACODE *-------------------------------------- KW.FCODE lda #E.SYN sec rts *-------------------------------------- MAN SAVE usr/src/bin/forth.s.kw LOAD usr/src/bin/forth.s ASM