A2osX/BIN/FORTH.S.KW.txt

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