tm@polari.UUCP (Toshi Morita) (07/30/90)
This is an include file for QForth.
********************************
* Start special compiler words 1
********************************
*
* Read more of filename - called by READSUB
*
READMORE JSR READFILE ; Read file
BEQ :MORECHR
STZ AGAIN ; If no more characters then mark as
; last read
:MORECHR LDA #DATA ; Set up pointer to the start of text
STA FILEPNTR ; we've just read so we can
LDA #/DATA ; process it
STA FILEPNTR+1
RTS
*
* Word "read" - compile text file
*
WORD1 ASC 'read '
DW READ
AGAIN HEX 00
READ BRK ; Special executable compiler subroutine
JSR SKIP2SPC ; Skip over this word ("read")
JSR SKIPSPCS ; Skip to filename to read
LDA #$20 ; JSR READSUB
JSR OUTBYTE
LDA #READSUB
JSR OUTBYTE
LDA #/READSUB
JSR OUTBYTE
JSR TEXTOUT ; Output text of filename
TYA
BEQ :ERROR
LDA #$00 ; Null-terminate string
JMP OUTBYTE
:ERROR LDA #$17 ; "READ without filename"
JMP PRTERR
*
READSUB PLA
STA PNTR
PLA
STA PNTR+1
INC PNTR
BNE :SKIPINC
INC PNTR+1
:SKIPINC LDY #$00 ; Move filename to FILENAME
:LOOP LDA (PNTR),Y
BEQ :EOL
STA FILENAME+1,Y
INY
BRA :LOOP
:EOL STY FILENAME ; Set up length byte
JSR GFI ; GET_FILE_INFO
LDA PARMS+4 ; Make sure it's a text file
CMP #$04
BNE :ERROR2
JSR OPENFILE ; Open the file so we can read it
SEC ; We've successfully opened file
ROR FILE ; so if an error occurs close it
SEC
ROR AGAIN
JSR READMORE ; Read the file
:OUTER LDY #$00 ; Read a string terminated by return into
:LOOP2 LDA (FILEPNTR) ; input buffer so we can execute it
STA INPUT,Y
INC FILEPNTR ; Bump pointer
BNE :NEXTCHR
INC FILEPNTR+1 ; If pointer hit end of data buffer...
LDX FILEPNTR+1
CPX #/DATA+DATALEN
BNE :NEXTCHR
LDA AGAIN ; and there is more data in file...
BEQ :EOF
PHA ; then read more of file into buffer
PHY
JSR READMORE
PLY
PLA
:NEXTCHR INY
CMP #$0D
BNE :LOOP2
JSR INTERP ; Execute string
BRA :OUTER
:EOF STZ FILE ; Clear file open flag
JSR CLOSFILE ; Close file
JMP CMDINIT ; So it won't try to execute remaining text
:ERROR2 LDA #$18 ; "Can't READ a non-text file"
JMP PRTERR
*
* Subroutine for adding words
*
ADDSUB JSR SETCEOS ; Set compiler output to end-of-system
LDA COUTPUT ; Set up PNTR for ADDWORD call
STA PNTR3
LDA COUTPUT+1
STA PNTR3+1
:LOOP LDA (WORDPNTR) ; Output word text
CMP #$20
BEQ :EOL
CMP #$0D
BEQ :EOL
JSR OUTBYTE
INC WORDPNTR
BNE :LOOP
INC WORDPNTR+1
BRA :LOOP
:EOL LDA #$20 ; Append trailing space
JSR OUTBYTE
JMP ADDWORD ; Add word to dictionary
; (CALCHASH has already been called)
*
* Subroutine for outputting word text
*
TEXTOUT LDY #$00 ; Output variable's name
:LOOP LDA (WORDPNTR),Y
CMP #$0D
BEQ :END
CMP #$20
BEQ :END
JSR OUTBYTE
INY
BRA :LOOP
:END RTS
*
* Subroutine to resume execution after text string
*
RESUME LDY #$FF
:LOOP INY
LDA (WORDPNTR),Y
CMP #$20
BNE :LOOP
TYA
CLC
ADC WORDPNTR
TAY
LDX WORDPNTR+1
BCC :NOINC
INX
:NOINC PHX
PHY
RTS
*
* Word ":" - Define new word
*
WORD2 ASC ': '
DW COLON
COLON BRK ; Special executable compiler word
BIT COMPILE ; Make sure we're not already compiling
BPL :NOTCOMP
LDA #$08 ; "Cannot define colon definition
JMP PRTERR ; within another colon definition"
:NOTCOMP LDA #$FF ; Set compiling flag and
STA COMPILE ; "compile next word" flag
STA CFLAG1
RTS
* Word ":" - 2nd half (compiler subroutine)
COLON2 STZ CFLAG1 ; Clear out "Add word" flag
JSR CHKNUM ; Make sure it isn't a number
BCC :NOTNUM
LDA #$09 ; "Cannot define number as new word"
JMP PRTERR
:NOTNUM JSR CALCHASH ; Make sure it isn't in vocabulary already
JSR CHKWORD
BCC :ISNEW
STZ COMPILE ; So GETSEINIT won't forget last word
LDA #$0A ; "Word already defined"
JMP PRTERR
:ISNEW JSR ADDSUB ; Add this word to vocabulary
LDA COUTPUT ; Calculate pointer to address of routine
CLC
ADC #$02
TAY
LDA COUTPUT+1
ADC #$00
PHA
TYA
JSR OUTBYTE
PLA
JMP OUTBYTE
*
* Word ";" - End colon definition (compiler subroutine)
*
WORD3 ASC '; '
DW SEMICLN
SEMICLN BRK ; Special executable compiler subroutine
LDA COMPILE
BNE :OK
LDA #$0B ; "Semicolon without colon"
JMP PRTERR
:OK LDA #$60 ; Add RTS to colon definition
JSR OUTBYTE
STZ COMPILE
JMP SETEOSC ; Set end-of-system to compiler output
*
* Word "variable" - allocate space for a variable
*
WORD4 ASC 'variable '
DW VARIABLE
VARIABLE BRK ; Special executable compiler subroutine
JSR SKIP2SPC ; Skip past this word ("variable")
JSR SKIPSPCS ; Skip to variable to define
JSR CHKNUM ; Make sure it isn't a number
BCC :NOTNUM
LDA #$12 ; "Cannot define number as variable"
JMP PRTERR
:NOTNUM LDA #$20 ; JSR VARSUB
JSR OUTBYTE
LDA #VARSUB
JSR OUTBYTE
LDA #/VARSUB
JSR OUTBYTE
JSR TEXTOUT ; Output variable's name
TYA
BEQ :ERROR
LDA #$20
JMP OUTBYTE
:ERROR LDA #$15 ; "No word following 'variable'"
JMP PRTERR
*
VARSUB PLA
STA WORDPNTR
PLA
STA WORDPNTR+1
INC WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC JSR CALCHASH ; Make sure it isn't in vocabulary already
JSR CHKWORD
BCC :ISNEW
LDA #$0A ; "Word already defined"
JMP PRTERR
:ISNEW JSR SETCEOS ; Set compiler output to end-of-system
JSR ADDSUB ; Add this word to vocabulary
LDA COUTPUT ; Calculate pointer to address of routine
CLC
ADC #$02
TAY
LDA COUTPUT+1
ADC #$00
PHA
TYA
JSR OUTBYTE
PLA
JSR OUTBYTE
LDA COUTPUT ; Calculate variable location
CLC
ADC #$07
STA PNTR
LDA COUTPUT+1
ADC #$00
STA PNTR+1
LDA #$A0 ; LDY #variable location
JSR OUTBYTE
LDA PNTR
JSR OUTBYTE
LDA #$A2 ; LDX #/variable location
JSR OUTBYTE
LDA PNTR+1
JSR OUTBYTE
LDA #$4C ; JMP PUSHDATA
JSR OUTBYTE
LDA #PUSHDATA
JSR OUTBYTE
LDA #/PUSHDATA
JSR OUTBYTE
LDA #$00 ; Reserve space for variable
JSR OUTBYTE
JSR OUTBYTE
JSR SETEOSC ; Set end-of-system to compiler output
JMP RESUME ; Resume execution after variable text
*
* Word "constant" - create a constant
*
WORD5 ASC 'constant '
DW CONSTANT
CONSTANT BRK ; Special executable compiler subroutine
JSR SKIP2SPC ; Skip past this word ("constant")
JSR SKIPSPCS ; Skip to constant to define
JSR CHKNUM ; Make sure it isn't a number
BCC :NOTNUM
LDA #$13 ; "Cannot define number as constant"
JMP PRTERR
:NOTNUM LDA #$20 ; JSR CONSTSUB
JSR OUTBYTE
LDA #CONSTSUB
JSR OUTBYTE
LDA #/CONSTSUB
JSR OUTBYTE
JSR TEXTOUT ; Output constant's name
TYA
BEQ :ERROR
LDA #$20
JMP OUTBYTE
:ERROR LDA #$15 ; "No word following 'constant'"
JMP PRTERR
*
CONSTSUB PLA
STA WORDPNTR
PLA
STA WORDPNTR+1
INC WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC JSR CALCHASH ; Make sure it isn't in vocabulary already
JSR CHKWORD
BCC :ISNEW
LDA #$0A ; "Word already defined"
JMP PRTERR
:ISNEW JSR SETCEOS ; Set compiler output to end-of-system
JSR ADDSUB ; Add this word to vocabulary
LDA COUTPUT ; Calculate pointer to address of routine
CLC
ADC #$02
TAY
LDA COUTPUT+1
ADC #$00
PHA
TYA
JSR OUTBYTE
PLA
JSR OUTBYTE
JSR POPDATA ; GET constant value
STY PNTR
STX PNTR+1
LDA #$A0 ; LDY #constant value
JSR OUTBYTE
LDA PNTR
JSR OUTBYTE
LDA #$A2 ; LDX #/constant value
JSR OUTBYTE
LDA PNTR+1
JSR OUTBYTE
LDA #$4C ; JMP PUSHDATA
JSR OUTBYTE
LDA #PUSHDATA
JSR OUTBYTE
LDA #/PUSHDATA
JSR OUTBYTE
JSR SETEOSC ; Set end-of-system to compiler output
JMP RESUME ; Resume execution after constant text
*
* Word "create" - create new word
*
WORD6 ASC 'create '
DW CREATE
CREATE BRK ; Special executable compiler subroutine
JSR SKIP2SPC ; Skip past this word ("create")
JSR SKIPSPCS ; Skip to word to create
JSR CHKNUM ; Make sure it isn't a number
BCC :NOTNUM
LDA #$14 ; "Cannot define number as array"
JMP PRTERR
:NOTNUM LDA #$20 ; JSR CREATSUB
JSR OUTBYTE
LDA #CREATSUB
JSR OUTBYTE
LDA #/CREATSUB
JSR OUTBYTE
JSR TEXTOUT ; Output constant's name
TYA
BEQ :ERROR
LDA #$20
JMP OUTBYTE
:ERROR LDA #$15 ; "No word following 'create'"
JMP PRTERR
*
CREATSUB PLA
STA WORDPNTR
PLA
STA WORDPNTR+1
INC WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC JSR CALCHASH ; Make sure it isn't in vocabulary already
JSR CHKWORD
BCC :ISNEW
LDA #$0A ; "Word already defined"
JMP PRTERR
:ISNEW JSR SETCEOS ; Set compiler output to end-of-system
JSR ADDSUB ; Add this word to vocabulary
LDA COUTPUT ; Calculate pointer to address of routine
CLC
ADC #$02
TAY
LDA COUTPUT+1
ADC #$00
TAX
TYA
JSR OUTBYTE
TXA
JSR OUTBYTE
LDA COUTPUT ; Calculate address of storage area
CLC
ADC #$07
TAY
LDA COUTPUT+1
ADC #$00
TAX
LDA #$A0 ; LDY #storage area
JSR OUTBYTE
TYA
JSR OUTBYTE
LDA #$A2 ; LDX #/storage area
JSR OUTBYTE
TXA
JSR OUTBYTE
LDA #$4C ; JMP PUSHDATA
JSR OUTBYTE
LDA #PUSHDATA
JSR OUTBYTE
LDA #/PUSHDATA
JSR OUTBYTE
JSR SETEOSC ; Set end-of-system to compiler output
JMP RESUME ; Resume execution after constant text
*
* Word "allot" - allot space for data
*
WORD7 ASC 'allot '
DW ALLOT
ALLOT JSR POPDATA ; Figure out how many bytes to allot
TYA
CLC
ADC EOSPNTR
STA EOSPNTR
TXA
ADC EOSPNTR+1
STA EOSPNTR+1
RTS
*
* Word "," - Compile stack value into next two bytes
*
WORD8 ASC ', '
DW COMMA
COMMA JSR SETCEOS ; Set compiler output to end-of-system
JSR POPDATA
TYA
JSR OUTBYTE
TXA
JSR OUTBYTE
JMP SETEOSC ; Set end-of-system to compiler output
*
* Word "c," - Compile stack value into next byte
*
WORD9 ASC 'c, '
DW CCOMMA
CCOMMA JSR SETCEOS ; Set compiler output to end-of-system
JSR POPDATA
TYA
JSR OUTBYTE
JMP SETEOSC ; Set end-of-system to compiler output
*
* Word "forget" - undefine words
*
WORD10 ASC 'forget '
DW FORGET
FORGET BRK ; Special executable compiler subroutine
JSR SKIP2SPC ; Skip past this word ("forget")
JSR SKIPSPCS ; Skip to word to forget
JSR CHKNUM ; Make sure it isn't a number
BCC :NOTNUM
LDA #$16 ; "Cannot forget number 'xxx'"
JMP PRTERR
:NOTNUM LDA #$20 ; JSR FRGTSUB
JSR OUTBYTE
LDA #FRGTSUB
JSR OUTBYTE
LDA #/FRGTSUB
JSR OUTBYTE
JSR TEXTOUT ; Output word's name
TYA
BEQ :ERROR
LDA #$20
JMP OUTBYTE
:ERROR LDA #$15 ; "No word following 'forget'"
JMP PRTERR
*
FRGTSUB PLA
STA WORDPNTR
PLA
STA WORDPNTR+1
INC WORDPNTR
BNE :SKIPINC
INC WORDPNTR+1
:SKIPINC JSR CALCHASH ; Calculate hash of word
JSR CHKWORD ; Make sure it's in dictionary
BCS :LOOP
LDA #$07 ; "Word 'xxx' not found"
JMP PRTERR
:LOOP JSR FRGTLAST ; Forget last word
LDY #$02 ; Until we forget the one we want
LDA (LISTPNTR),Y
CMP PNTR2
BNE :LOOP
INY
LDA (LISTPNTR),Y
CMP PNTR2+1
BNE :LOOP
LDA PNTR2 ; Reset compiler end-of-system
STA EOSPNTR ; and reclaim space
LDA PNTR2+1
STA EOSPNTR+1
JMP RESUME ; Resume execution after constant text
********************************
* End special compiler words 1
********************************