Apple-2-SW/A2osX
1
0
Fork 0
mirror of https://github.com/A2osX/A2osX.git synced 2024-11-25 05:32:20 +00:00
Code Issues Projects Releases Wiki Activity
d249f0c0b9
A2osX/BIN/FORTH.S.KW.txt
burniouf 5e630a020f FORTH: bugfix for TYPE, updated .md file
2021-08-10 17:36:57 +02:00

1166 lines
17 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

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
stz 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
>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
>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
Reference in New Issue View Git Blame Copy Permalink