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.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