tm@polari.UUCP (Toshi Morita) (08/01/90)
Include file for QForth:
********************************
* Start special compiler words 2
********************************
*
* Word "if" - Conditional execution (compiler subroutine)
*
WORD11 ASC 'if '
DW IF
IF BRK ; Special executable compiler subroutine
LDA #$20 ; JSR IF
JSR OUTBYTE
LDA #IFSUB
JSR OUTBYTE
LDA #/IFSUB
JSR OUTBYTE
LDA #$D0 ; BNE (three bytes ahead to true (nonzero))
JSR OUTBYTE
LDA #$03
JSR OUTBYTE
LDA #$4C ; JMP (to false (zero))
JSR OUTBYTE
LDY COUTPUT ; Push patch location
LDX COUTPUT+1
JSR PUSHCOMP
LDY #$01 ; Compiler state $0001 (wait for ELSE)
LDX #$00
JSR PUSHCOMP
LDA #$00 ; (JMP) $0000
JSR OUTBYTE
JSR OUTBYTE
RTS
*
IFSUB JSR POPDATA
STX TEMP
TYA
ORA TEMP
RTS
*
* Word "else" - False part of conditional (compiler subroutine)
*
WORD12 ASC 'else '
DW ELSE
ELSE BRK ; Special executable compiler subroutine
JSR POPCOMP
CPY #$01
BEQ :OK
LDA #$06 ; "ELSE without matching IF"
JMP PRTERR
:OK JSR POPCOMP ; Fetch the patch location for IF
STY PNTR
STX PNTR+1
LDA #$4C ; Compile JMP to where execution merges
JSR OUTBYTE
LDY COUTPUT ; Push patch location
LDX COUTPUT+1
JSR PUSHCOMP
LDY #$02 ; Compiler state $0002 (waiting for THEN)
LDX #$00
JSR PUSHCOMP
LDA #$00 ; (JMP) $0000
JSR OUTBYTE
JSR OUTBYTE
LDA COUTPUT ; Patch the JMP to false section for IF
STA (PNTR)
LDY #$01
LDA COUTPUT+1
STA (PNTR),Y
RTS
*
* Word "then" - Resume execution after conditional
*
WORD13 ASC 'then '
DW THEN
THEN BRK ; Special executable compiler subroutine
JSR POPCOMP ; Should be in compiler state $0002
CPY #$02
BEQ :OK
LDA #$07
JMP PRTERR
:OK JSR POPCOMP
STY PNTR
STX PNTR+1
LDA COUTPUT
STA (PNTR)
LDA COUTPUT+1
LDY #$01
STA (PNTR),Y
RTS
*
* Word "do" - Start of DO - LOOP/+LOOP
*
WORD14 ASC 'do '
DW DO
DO BRK ; Special executable compiler subroutine
LDA #$20 ; JSR DOSUB
JSR OUTBYTE
LDA #DOSUB
JSR OUTBYTE
LDA #/DOSUB
JSR OUTBYTE
LDY COUTPUT ; Push address to LOOP/+LOOP back to
LDX COUTPUT+1
JSR PUSHCMP2
LDY #$03 ; Compiler state $0003 - waiting for
LDX #$00 ; LEAVE, LOOP or +LOOP
JMP PUSHCMP2
*
DOSUB JSR POPDATA ; Get loop initial counter value
JSR PUSHRETN ; Push it to return stack
JSR POPDATA ; Get loop limit counter value
JMP PUSHRETN ; Push it to return stack
*
* Subroutine PATCHLV used by LOOP/+LOOP to patch LEAVES
*
PATCHLV JSR POPCMP2
CPY #$04 ; Check for LEAVEs to be patched
BNE :NOTLEAV
JSR POPCMP2 ; There is a LEAVE to be patched
STY PNTR
STX PNTR+1
LDA COUTPUT
CLC
ADC #$08
STA (PNTR)
LDA COUTPUT+1
ADC #$00
LDY #$01
STA (PNTR),Y
BRA PATCHLV
:NOTLEAV JMP PUSHCMP2 ; It's not a $0004 so push it back
; and exit
*
* Word "loop" - End of DO-LOOP
*
WORD15 ASC 'loop '
DW LOOP
LOOP BRK ; Special executable compiler subroutine
JSR PATCHLV ; Patch any LEAVEs that need to be done
JSR POPCMP2 ; Should be in compiler state $0003
CPY #$03
BEQ :OK
LDA #$0F ; "LOOP without DO"
JMP PRTERR
:OK LDA #$20 ; JSR LOOPSUB
JSR OUTBYTE
LDA #LOOPSUB
JSR OUTBYTE
LDA #/LOOPSUB
JSR OUTBYTE
LDA #$F0 ; BEQ three bytes ahead
JSR OUTBYTE
LDA #$03
JSR OUTBYTE
LDA #$4C ; JMP (patch area)
JSR OUTBYTE
JSR POPCMP2
STX TEMP
TYA
JSR OUTBYTE
LDA TEMP
JMP OUTBYTE
*
LOOPSUB JSR POPRETN ; Pop loop counter limit value
STY PNTR
STX PNTR+1
JSR POPRETN ; Pop loop counter current value
INY
BNE :SKIPINC
INX
:SKIPINC CPY PNTR
BNE :NOTFIN
CPX PNTR+1
BNE :NOTFIN
RTS
:NOTFIN JSR PUSHRETN
LDY PNTR
LDX PNTR+1
JSR PUSHRETN
LDA #$FF ; Make BNE true
RTS
*
* Word "+loop" - End of DO-+LOOP
*
WORD16 ASC '+loop '
DW PLOOP
PLOOP BRK ; Special executable compiler subroutine
JSR PATCHLV ; Patch any LEAVEs that need to be done
JSR POPCMP2 ; Should be in compiler state $0003
CPY #$03
BEQ :OK
LDA #$0F ; "+LOOP without DO"
JMP PRTERR
:OK LDA #$20 ; JSR PLOOPSUB
JSR OUTBYTE
LDA #PLOOPSUB
JSR OUTBYTE
LDA #/PLOOPSUB
JSR OUTBYTE
LDA #$F0 ; BEQ three bytes ahead
JSR OUTBYTE
LDA #$03
JSR OUTBYTE
LDA #$4C ; JMP (patch area)
JSR OUTBYTE
JSR POPCMP2
STX TEMP
TYA
JSR OUTBYTE
LDA TEMP
JMP OUTBYTE
*
PLOOPSUB JSR POPRETN ; Pop loop counter limit value
STY PNTR
STX PNTR+1
JSR POPRETN ; Pop loop counter current value
STY PNTR2
STX PNTR2+1
JSR POPDATA ; Pop increment value
TYA
CLC
ADC PNTR2
TAY
TXA
ADC PNTR2+1
TAX
CPY PNTR
BNE :NOTFIN
CPX PNTR+1
BNE :NOTFIN
RTS
:NOTFIN JSR PUSHRETN
LDY PNTR
LDX PNTR+1
JSR PUSHRETN
LDA #$FF ; Make BNE true
RTS
*
* Word "leave" - Terminate DO - LOOP/+LOOP immediately
*
WORD17 ASC 'leave '
DW LEAVE
LEAVE BRK ; Special executable compiler word
JSR POPCMP2 ; Should be in compiler state $0003
CPY #$03 ; (waiting for a LOOP/+LOOP)
BEQ :OK ; or in state $0004
CPY #$04 ; (other LEAVEs on stack)
BEQ :OK
LDA #$0F ; "LEAVE without DO"
JMP PRTERR
:OK JSR PUSHCMP2 ; Push compiler state $0003 back on stack
LDA #$4C ; JMP absolute (to be patched)
JSR OUTBYTE
LDY COUTPUT ; Patch area
LDX COUTPUT+1
JSR PUSHCMP2
LDY #$04 ; Set compiler state $0004
LDX #$00
JSR PUSHCMP2
LDA #$00 ; Finish off JMP
JSR OUTBYTE
JMP OUTBYTE
*
* Word "i" - get counter value of innermost loop
* and leave it on the stack
*
WORD18 ASC 'i '
DW I
I LDA RETITEMS
BEQ :ERROR
LDX RETSTACK
LDA RETNAREA+3,X
TAY
LDA RETNAREA+4,X
TAX
JMP PUSHDATA
:ERROR LDA #06 ; "Return stack underflow"
JMP PRTERR
*
* Word "j" - get counter value of next innermost loop
* and leave it on the stack
*
WORD19 ASC 'j '
DW J
J LDA RETITEMS
BEQ :ERROR
LDX RETSTACK
LDA RETNAREA+7,X
TAY
LDA RETNAREA+8,X
TAX
JMP PUSHDATA
:ERROR LDA #06 ; "Return stack underflow"
JMP PRTERR
*
* Word "begin" - part of BEGIN - UNTIL/WHILE-REPEAT
*
WORD20 ASC 'begin '
DW BEGIN
BEGIN BRK ; Special executable compiler code
LDY COUTPUT ; Save marker location
LDX COUTPUT+1
JSR PUSHCOMP
LDY #$04 ; Set compiler state $0004
LDX #$00
JMP PUSHCOMP
*
* Word "until" - part of BEGIN-UNTIL
*
WORD21 ASC 'until '
DW UNTIL
UNTIL BRK ; Special executable compiler code
JSR POPCOMP ; Make sure we're in compiler state $0004
CPY #$04
BEQ :OK
LDA #$10 ; "UNTIL without BEGIN"
JMP PRTERR
:OK LDA #$20 ; JSR IFSUB (borrow it since it's same)
JSR OUTBYTE
LDA #IFSUB
JSR OUTBYTE
LDA #/IFSUB
JSR OUTBYTE
LDA #$D0 ; BNE (three bytes ahead)
JSR OUTBYTE
LDA #$03
JSR OUTBYTE
LDA #$4C ; JMP (marker location)
JSR OUTBYTE
JSR POPCOMP
STX TEMP
TYA
JSR OUTBYTE
LDA TEMP
JMP OUTBYTE
*
* Word "while" - part of BEGIN-WHILE-REPEAT
*
WORD22 ASC 'while '
DW WHILE
WHILE BRK ; Special executable compiler code
JSR POPCOMP ; Make sure we're in compiler state $0004
CPY #$04
BEQ :OK
LDA #$10 ; "while without begin"
JMP PRTERR
:OK LDA #$20 ; JSR IFSUB
JSR OUTBYTE
LDA #IFSUB
JSR OUTBYTE
LDA #/IFSUB
JSR OUTBYTE
LDA #$D0 ; BNE (three bytes ahead)
JSR OUTBYTE
LDA #$03
JSR OUTBYTE
LDA #$4C ; JMP (out of loop - patch area)
JSR OUTBYTE
LDY COUTPUT ; Push patch area onto compiler stack
LDX COUTPUT+1
JSR PUSHCOMP
LDA #$00 ; Finish off JMP instruction
JSR OUTBYTE
JSR OUTBYTE
LDY #$05 ; Set compiler mode $0005
LDX #$00
JMP PUSHCOMP
*
* Word "repeat" - part of BEGIN-WHILE-REPEAT
*
WORD23 ASC 'repeat '
DW REPEAT
REPEAT BRK ; Special executable compiler word
JSR POPCOMP ; Make sure we're in compiler state $0005
CPY #$05
BEQ :OK
LDA #$11 ; "repeat without begin-while"
JMP PRTERR
:OK LDA #$4C ; JMP (back to beginning)
JSR OUTBYTE
JSR POPCOMP ; Pop patch area out of loop
STY PNTR2
STX PNTR2+1
JSR POPCOMP ; Pop marked area for beginning
STX TEMP ; and finish off JMP
TYA
JSR OUTBYTE
LDA TEMP
JSR OUTBYTE
LDA COUTPUT ; Patch area for out of loop
STA (PNTR2)
LDA COUTPUT+1
LDY #$01
STA (PNTR2),Y
RTS
*
* Subroutine used by ." and lit"
*
STROUT STA TEMP2
STX TEMP3
JSR SKIP2SPC ; Skip to string
LDA (WORDPNTR)
CMP #$0D
BEQ :ERROR
INC WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC LDA (WORDPNTR)
CMP #$0D
BEQ :ERROR
LDY #$FF ; Look for ending quote
:LOOP INY
LDA (WORDPNTR),Y
CMP #$0D
BEQ :ERROR
CMP TEMP3 ; Delimiter
BNE :LOOP
STY TEMP ; Save string length
BIT TEMP2
BPL :NOCOUNT
TYA
JSR OUTBYTE
:NOCOUNT TYA ; Output string
TAX
LDY #$00
:LOOP2 LDA (WORDPNTR),Y
JSR OUTBYTE
INY
DEX
BNE :LOOP2
BIT TEMP2 ; Null-terminate if necessary
BMI :NONULL
TXA
JSR OUTBYTE
:NONULL LDA TEMP ; Update WORDPNTR
SEC
ADC WORDPNTR
STA WORDPNTR
BCC :SKPINC2
INC WORDPNTR+1
:SKPINC2 RTS
:ERROR LDA #$0C ; "No ending quote found for expression"
JMP PRTERR
*
* Word /."/ - Print out a text string
*
WORD24 ASC '.'
ASC '"'
ASC ' '
DW PRDQUOTE
PRDQUOTE BRK ; Special executable compiler word
LDA #$20 ; JSR MSGOUT
JSR OUTBYTE
LDA #MSGOUT
JSR OUTBYTE
LDA #/MSGOUT
JSR OUTBYTE
LDA #$00
LDX #$22
JMP STROUT
:ERROR LDA #$0C ; "No ending quote found for .""
JMP PRTERR
*
* Word /"/ - End of print string
*
WORD25 ASC '" '
DW QUOTE
QUOTE BRK ; Special executable compiler word
LDA #$19 ; /End quote without ."/
JMP PRTERR
*
* Word "string" - compiles counted string literal
* into dictionary
*
WORD26 ASC 'string '
DW STRING
STRING BRK ; Special executable compiler word
LDA #$20 ; JSR STRSUB
JSR OUTBYTE
LDA #STRSUB
JSR OUTBYTE
LDA #/STRSUB
JSR OUTBYTE
LDA #$00
LDX #$7E ; Tilde
JMP STROUT
*
STRSUB PLA
STA WORDPNTR
PLA
STA WORDPNTR+1
LDY #$01 ; Output variable's name
:LOOP LDA (WORDPNTR),Y
BEQ :EOL
JSR OUTBYTE
INY
BRA :LOOP
:EOL TYA
CLC
ADC WORDPNTR
TAX
LDA WORDPNTR+1
ADC #$00
PHA
PHX
RTS
*
* Word /lit"/ - compiles counted string, returns address
*
WORD27 ASC 'lit'
HEX 22
ASC ' '
DW LITQUOTE
LITQUOTE BRK ; Special executable compiler word
LDA COUTPUT
CLC
ADC #$09
STA PNTR
LDA COUTPUT+1
ADC #$00
STA PNTR+1
LDA #$A0 ; LDY #string
JSR OUTBYTE
LDA COUTPUT
LDA PNTR
JSR OUTBYTE
LDA #$A2 ; LDX #/string
JSR OUTBYTE
LDA PNTR+1
JSR OUTBYTE
LDA #$20 ; JSR PUSHDATA
JSR OUTBYTE
LDA #PUSHDATA
JSR OUTBYTE
LDA #/PUSHDATA
JSR OUTBYTE
LDA #$80 ; BRA opcode
JSR OUTBYTE
LDA COUTPUT
STA PNTR2
LDA COUTPUT+1
STA PNTR2+1
LDA #$00
JSR OUTBYTE
LDA #$80 ; Output string
LDX #$22 ; Double quote
JSR STROUT
LDA TEMP
INC
STA (PNTR2)
RTS
*
* Word "(" - Start of comment
*
WORD28 ASC '( '
DW LEFTPAR
LEFTPAR BRK ; Special executable compiler word
LDY #$FF ; Find right parentheses
:LOOP INY
LDA (WORDPNTR),Y
CMP #$0D
BEQ :ERROR
CMP #')'
BNE :LOOP
INY ; Move word text pointer past
TYA ; right parentheses
CLC
ADC WORDPNTR
STA WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC RTS
:ERROR JMP PRTERR ; "No matching right parentheses
; for comment"
; (Accumulator is already $0D)
*
* Word ")" - End of comment
*
WORD29 ASC ') '
DW RIGHTPAR
RIGHTPAR LDA #$1A ; "Right parentheses without matching
JMP PRTERR ; left parentheses"
*
* Word "'" - Throw address of next word on stack
*
WORD30 HEX 27
ASC ' '
DW TICK
TICK BRK ; Special executable compiler word
JSR SKIP2SPC ; Move pointer to next word
JSR SKIPSPCS
LDA #$20 ; JSR TICKSUB
JSR OUTBYTE
LDA #TICKSUB
JSR OUTBYTE
LDA #/TICKSUB
JSR OUTBYTE
JSR TEXTOUT ; Output word text
LDA #' ' ; Space-terminate text
JSR OUTBYTE
JMP SKIP2SPC ; Move pointer past word
*
TICKSUB PLA ; Fetch text address
STA WORDPNTR
PLA
STA WORDPNTR+1
INC WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC JSR CALCHASH ; Calculate hash of text
JSR CHKWORD ; Look it up
BCC :ERROR
LDY PNTR ; Throw address of word on stack
LDX PNTR+1
JSR PUSHDATA
JMP RESUME ; Resume execution after text
:ERROR LDA #07 ; "Word not found"
JMP PRTERR
********************************
* End special compiler words 2
********************************