tm@polari.UUCP (Toshi Morita) (07/23/90)
This is the TINCMP compiler that compiles Pidgin programs. You will need
the macros to compile Pidgin with this program.
*
* Pidgin compiler
*
* Compiler for Pidgin as described in
* "Pidgin - A Systems Programming Language"
* (Dr. Dobb's Journal, Number 57, July 1981, pp. 10-14)
*
* Started: 7/31/88 @ 3:36 am
* Rewritten: 8/04/88 @ 1:05 pm
*
LST OFF
XC ; 65C02 opcodes
ORG $2000
*
* Zero page equates
*
PNTR EQU $00
PNTR2 EQU $02
PNTR3 EQU $04
INDATA EQU $06
BYTES EQU $08
OUTDATA EQU $0A
BYTES2 EQU $0C
TEMPLATE EQU $19 ; Template flag
LENGTH EQU $1A ; String length
CH EQU $24
CV EQU $25
EOF EQU $E0
NEWLN EQU $E1 ; Newline flag
BEGIN EQU $E2 ; Begin-template character
ENDLINE EQU $E3 ; End-line character
PARM EQU $E4 ; Parameter flag character
OPCODE EQU $E5 ; Operation code character
IGNORE EQU $E6 ; "Ignore" character (usually space)
FREEPNTR EQU $F0
LASTNODE EQU $F2
FETCHED EQU $F4
STKPNTR EQU $F6
TEMP EQU $F7
TEMP2 EQU $F8
TEMP3 EQU $F9
UNIQUE EQU $FA ; Two bytes
LARGEST EQU $FC
UNIQUSED EQU $FD
*
* Program data equates
*
INPUT EQU $200
FILE1 EQU $300 ; Macros filename
FILE2 EQU $331 ; Program filename
FILE3 EQU $362 ; Output filename
READBUF EQU $800
READLEN EQU $1800
WRITEBUF EQU $9F00
WRITELEN EQU $2000
MLI EQU $BF00
*
* ROM equates
*
HOME EQU $C300
BASCALC EQU $FC22
GETKEY EQU $FD0C
COUT EQU $FDED
*
* Start of actual code
*
JMP MAIN
********************************
********************************
* Start ProDOS interface
********************************
********************************
*
* Data area
*
REFNUM1 HEX 00 ; Input file reference #
REFNUM2 HEX 00 ; Output file reference #
********************************
* Start macro file ProDOS subroutines
********************************
*
* Open macros file
*
OPENMAC JSR MLI ; Open command
HEX C8
DW :PARMS
LDA :REFNUM ; Save reference number of macros file
STA REFNUM1
STZ EOF ; Clear EOF flag
RTS
:PARMS HEX 03
DW FILE1
DW IFILEBUF
:REFNUM HEX 00
*
* Read macros file
*
READMAC LDA REFNUM1 ; Get reference number of
STA :REFNUM ; macros file
********************************
LDA #$31
STA $400
********************************
JSR MLI ; Read command
HEX CA
DW :PARMS
********************************
LDA #" "
STA $400
********************************
LDA :ACTUAL ; Set byte counter to # of bytes loaded
STA BYTES
LDA :ACTUAL+1
STA BYTES+1
LDA #READBUF ; Set input pointer to start of data
STA INDATA
LDA #/READBUF
STA INDATA+1
LDA :ACTUAL ; Check to see if we hit EOF
CMP #READLEN
BNE :EOF
LDA :ACTUAL+1
CMP #/READLEN
BNE :EOF
RTS
:EOF SEC
ROR EOF
RTS
:PARMS HEX 04
:REFNUM HEX 00
DW READBUF
DW READLEN
:ACTUAL HEX 0000
*
* Close macros
*
CLOSEMAC LDA REFNUM1 ; Set up reference # of macros file
STA :REFNUM
JSR MLI ; Close command
HEX CC
DW :PARMS
RTS
:PARMS HEX 01
:REFNUM HEX 00
********************************
* End macros file ProDOS subroutines
********************************
********************************
* Start program file ProDOS subroutines
********************************
*
* Open program file
*
OPENPROG JSR MLI ; Open command
HEX C8
DW :PARMS
LDA :REFNUM ; Save reference number of program file
STA REFNUM1
STZ EOF ; Clear EOF flag
RTS
:PARMS HEX 03
DW FILE2
DW IFILEBUF
:REFNUM HEX 00
*
* Read program file
*
READPROG LDA REFNUM1 ; Get reference number of
STA :REFNUM ; program file
********************************
LDA #$31
STA $400
********************************
JSR MLI ; Read command
HEX CA
DW :PARMS
********************************
LDA #" "
STA $400
********************************
LDA :ACTUAL ; Set byte counter to # of bytes loaded
STA BYTES
LDA :ACTUAL+1
STA BYTES+1
LDA #READBUF ; Set input pointer to start of data
STA INDATA
LDA #/READBUF
STA INDATA+1
LDA :ACTUAL ; Check to see if we hit EOF
CMP #READLEN
BNE :EOF
LDA :ACTUAL+1
CMP #/READLEN
BNE :EOF
RTS
:EOF SEC
ROR EOF
RTS
:PARMS HEX 04
:REFNUM HEX 00
DW READBUF
DW READLEN
:ACTUAL HEX 0000
*
* Close program file
*
CLOSEPRG LDA REFNUM1 ; Set up reference # of program file
STA :REFNUM
JSR MLI ; Close command
HEX CC
DW :PARMS
RTS
:PARMS HEX 01
:REFNUM HEX 00
********************************
* End program file ProDOS subroutines
********************************
********************************
* Start output file ProDOS subroutines
********************************
*
* Open output file
*
OPENOUT JSR MLI ; Destroy command
HEX C1
DW :PARMS
JSR MLI ; Create command
HEX C0
DW :PARMS2
JSR MLI ; Open command
HEX C8
DW :PARMS3
LDA :REFNUM ; Save reference number of program file
STA REFNUM2
LDA #WRITEBUF ; Set up output data location
STA OUTDATA
LDA #/WRITEBUF
STA OUTDATA+1
RTS
:PARMS HEX 01 ; Destroy parms
DW FILE3
:PARMS2 HEX 07 ; Create parms
DW FILE3
HEX E3 ; File access privs
HEX 04 ; TXT file
HEX 00 ; Auxiliary type
HEX 01 ; Storage type
HEX 0000 ; Create date
HEX 0000 ; Create time
:PARMS3 HEX 03 ; Open parms
DW FILE3
DW OFILEBUF
:REFNUM HEX 00
*
* Write output file
*
WRITEOUT LDA REFNUM2 ; Set up reference #
STA :REFNUM
********************************
LDA BYTES2+1
JSR $FDDA
LDA BYTES2
JSR $FDDA
********************************
LDA BYTES2 ; Set up # of bytes to write
STA :BYTES
LDA BYTES2+1
STA :BYTES+1
********************************
LDA #$31
STA $400
********************************
JSR MLI ; Write command
HEX CB
DW :PARMS
********************************
LDA #" "
STA $400
********************************
RTS
:PARMS HEX 04
:REFNUM HEX 00
DW WRITEBUF
:BYTES HEX 0000
:ACTUAL HEX 0000
*
* Close output file
*
CLOSEOUT LDA REFNUM2 ; Set up reference # of program file
STA :REFNUM
JSR MLI ; Close command
HEX CC
DW :PARMS
RTS
:PARMS HEX 01
:REFNUM HEX 00
********************************
* End output file ProDOS subroutines
********************************
********************************
********************************
* End ProDOS interface
********************************
********************************
********************************
********************************
* Start global subroutines
********************************
********************************
*
* Subroutine to print text
*
MSGOUT PLA
STA PNTR
PLA
STA PNTR+1
:LOOP INC PNTR
BNE :SKIPINC
INC PNTR+1
:SKIPINC LDA (PNTR)
BEQ :FINIS
JSR COUT
BRA :LOOP
:FINIS LDA PNTR+1
PHA
LDA PNTR
PHA
RTS
*
* Print text in input buffer
*
PRINTI LDY #$FF
:LOOP INY
LDA INPUT,Y
PHA
JSR COUT
PLA
CMP #$0D
BNE :LOOP
RTS
*
* Get a line of input
*
GETLN LDY #$00
:OUTER PHY
JSR GETKEY
PLY
CMP #$FF
BEQ :ERASE
CMP #$88
BNE :NOTBKSP
:ERASE TYA
BEQ :OUTER
DEY
LDA #" "
JSR COUT
LDA #$88
JSR COUT
JSR COUT
LDA #" "
JSR COUT
LDA #$88
JSR COUT
BRA :OUTER
:NOTBKSP CMP #$8D
BNE :NOTRETN
TYA
BEQ :OUTER
RTS
:NOTRETN CMP #$A0
BCC :OUTER
CPY #48
BCS :OUTER
JSR COUT
AND #$7F
STA INPUT,Y
INY
BRA :OUTER
********************************
********************************
* End global subroutines
********************************
********************************
********************************
********************************
* Start linked list maintenance subroutines
********************************
********************************
*
* Clear linked list
*
CLRLIST LDX #07 ; Clear pointer array
:LOOP STZ HASHTBLL,X
STZ HASHTBLH,X
DEX
BPL :LOOP
LDA #FREEAREA ; Initialize free area pointer
STA FREEPNTR
LDA #/FREEAREA
STA FREEPNTR+1
RTS
*
* Output byte to free area
*
FREEOUT STA (FREEPNTR)
INC FREEPNTR
BNE :SKIPINC
INC FREEPNTR+1
:SKIPINC RTS
*
* Add a node to linked list
*
ADDNODE LDA LENGTH ; Check initial pointer
AND #07
TAY
LDA HASHTBLL,Y
ORA HASHTBLH,Y
BNE :TRAVERS
LDA FREEPNTR ; Create initial node
STA HASHTBLL,Y
LDA FREEPNTR+1
STA HASHTBLH,Y
LDY #01
BRA :CREATE
:TRAVERS LDA HASHTBLL,Y ; Set up pointer to linked list
STA PNTR
LDA HASHTBLH,Y
STA PNTR+1
LDY #01
:LOOP LDA (PNTR) ; Traverse linked list to tail node
TAX
ORA (PNTR),Y
BEQ :TAIL
LDA (PNTR),Y
STA PNTR+1
STX PNTR
BRA :LOOP
:TAIL LDA FREEPNTR ; Set up pointer to new tail node
STA (PNTR)
LDA FREEPNTR+1
STA (PNTR),Y
:CREATE LDA #$00 ; Pointer to next node of new node = NULL
STA (FREEPNTR)
STA (FREEPNTR),Y
INY ; Pointer to replacement text = NULL
STA (FREEPNTR),Y ; (until filled in)
INY
STA (FREEPNTR),Y
LDA FREEPNTR+1 ; Move FREEPNTR to LASTNODE
STA LASTNODE+1 ; and update FREEPNTR
LDA FREEPNTR
STA LASTNODE
CLC
ADC #04
STA FREEPNTR
BCC :SKIPINC
INC FREEPNTR+1
:SKIPINC RTS
*
* Compare two strings
*
COMPARE LDY #$FF
:LOOP INY
LDA (PNTR2),Y ; Fetch a character of template string
CMP PARM ; If it's a parameter char then don't
BEQ :LOOP ; check against input char
CMP #$0D ; If end of template then strings matched
BEQ :MATCH?
CMP INPUT,Y ; Check against input character
BEQ :LOOP
:NOMATCH CLC ; Strings did not match
RTS
:MATCH? LDA INPUT,Y ; Make sure it's end of input string too
CMP #$0D
BNE :NOMATCH
RTS
*
* Find matching node
*
FINDNODE LDA LENGTH ; See if initial pointer exists
AND #07
TAY
LDA HASHTBLL,Y
ORA HASHTBLH,Y
BEQ :NOMATCH
LDA HASHTBLL,Y ; Fetch initial pointer
STA PNTR
LDA HASHTBLH,Y
STA PNTR+1
:LOOP LDA PNTR ; Create pointer to node text
CLC
ADC #04
STA PNTR2
LDA PNTR+1
ADC #00
STA PNTR2+1
********************************
* JSR DEBUG2
********************************
JSR COMPARE ; Compare two strings
BCS :MATCH
LDA (PNTR) ; No match, so traverse linked list
TAX
LDY #01
LDA (PNTR),Y
STA PNTR+1
STX PNTR
ORA PNTR ; If not null pointer then continue
BNE :LOOP
:NOMATCH CLC ; No matching node found in list
RTS
:MATCH LDY #02 ; Return pointer to replacement string
LDA (PNTR),Y ; in PNTR3
STA PNTR3
INY
LDA (PNTR),Y
STA PNTR3+1
RTS ; Carry already set
********************************
********************************
* End linked list maintenance subroutines
********************************
********************************
********************************
********************************
* Start macros file subroutines
********************************
********************************
*
* Get a byte from macros file
*
GETBYTEM LDA BYTES ; Check if there are still bytes
ORA BYTES+1 ; left to be read in buffer
BNE :NOTLOAD
BIT EOF ; If we hit EOF already then there
BMI :EOF ; are no more bytes to read
PHY
JSR READMAC ; otherwise read more of file
PLY
:NOTLOAD LDA BYTES ; Decrement bytes in buffer
BNE :SKIPDEC
DEC BYTES+1
:SKIPDEC DEC BYTES
LDA (INDATA) ; Fetch a byte and increment input pointer
AND #$7F
INC INDATA
BNE :SKIPINC
INC INDATA+1
:SKIPINC SEC ; Return valid byte read
RTS
:EOF CLC ; No more bytes to read
RTS
*
* Get string of macros file
*
GETSTRM LDY #$00 ; Fetch first character
:LOOP JSR GETBYTEM
BCC :EOF
CMP IGNORE ; Ignore "ignore" characters
BEQ :LOOP
CMP #$0D ; Refetch null input
BEQ :LOOP
CMP BEGIN ; If it's a begin-template character
BEQ :GET_TEM ; then fetch rest of template
CMP ENDLINE ; If string starts with end-line
BEQ :WAITCR ; then it's a comment - wait for CR
STZ TEMPLATE ; Clear template flag
:LOOP2 STA INPUT,Y ; Fetch non-template string until CR
INY ; or end-line character
JSR GETBYTEM
BCC :EOF
CMP ENDLINE
BEQ :ENDNONT
CMP #$0D
BNE :LOOP2
STA INPUT,Y
RTS
:ENDNONT STA INPUT,Y ; Hit EOL character so skip till CR
INY
BRA :WAITCR
:GET_TEM SEC ; Set template flag
ROR TEMPLATE
:LOOP3 JSR GETBYTEM ; Keep fetching characters until
BCC :EOF ; end-line character
STA INPUT,Y
CMP ENDLINE
BEQ :WAITCR
INY
BRA :LOOP3
:WAITCR JSR GETBYTEM ; Skip characters until CR
BCC :EOF
CMP #$0D
BNE :WAITCR
STA INPUT,Y ; If null input then
TYA ; get another string
BEQ :LOOP
SEC
:EOF RTS
*
* Pick up six special characters out of macros file
*
GETSPCL STZ NEWLN
JSR GETBYTEM ; Fetch newline flag
CMP #'X'
BEQ :NO_NL
LDA #$FF
STA NEWLN
:NO_NL JSR GETBYTEM ; Fetch begin-template character
STA BEGIN
JSR GETBYTEM ; Fetch end-line character
STA ENDLINE
JSR GETBYTEM ; Fetch parameter flag character
STA PARM
JSR GETBYTEM ; Fetch operation code character
STA OPCODE
JSR GETBYTEM ; Fetch "ignore" character
STA IGNORE
RTS
*
* Output string in input buffer
*
OUTSTR LDY LENGTH ; Output string to free area
:LOOP LDA INPUT,Y
STA (FREEPNTR),Y
DEY
BNE :LOOP
LDA INPUT,Y
STA (FREEPNTR),Y
LDA FREEPNTR ; Update FREEPNTR
SEC
ADC LENGTH
STA FREEPNTR
BCC :SKIPINC
INC FREEPNTR+1
:SKIPINC RTS
*
* Read in & process macros file
*
DOMACROS JSR CLRLIST ; Clear linked list
JSR OPENMAC ; Open macros file
JSR READMAC ; Initial read of macros file
JSR GETSPCL ; Get special characters
:LOOP JSR GETSTRM ; Get a string of macros file
BCC :FINIS
STY LENGTH
********************************
* JSR DEBUG1
********************************
BIT TEMPLATE ; See if it's a template
BMI :ADDTEMP
LDY #$02 ; Check if pointer to replacement string
LDA (LASTNODE),Y ; has already been filled in
INY
ORA (LASTNODE),Y
BNE :NOSTORE
LDA FREEPNTR+1 ; Fill in pointer to replacement string
STA (LASTNODE),Y
DEY
LDA FREEPNTR
STA (LASTNODE),Y
:NOSTORE JSR OUTSTR ; Output opcode string
BRA :LOOP
:ADDTEMP LDA #00 ; Mark end of previous node's
JSR FREEOUT ; replacement string
JSR ADDNODE ; Add a node to linked list
JSR OUTSTR ; Output template string
BRA :LOOP
:FINIS LDA #$00 ; Terminate last replacement string
JSR FREEOUT
JMP CLOSEMAC ; Close macros file
********************************
********************************
* End macros file subroutines
********************************
********************************
********************************
********************************
* Start program file subroutines
********************************
********************************
********************************
* Start pseudo-stack code for string execute code
********************************
*
* Initialize pseudo-stack
*
INITSTCK LDA #$FF
STA STKPNTR
RTS
*
* Push word onto stack
*
PUSH
********************************
* PHX
* PHA
* PHX
* JSR $FDDA
* PLA
* JSR $FDDA
* PLA
* PLX
********************************
STX TEMP
LDX STKPNTR
STA STACK,X
DEX
LDA TEMP
STA STACK,X
DEX
STX STKPNTR
RTS
*
* Copy top of stack & pop
*
POP LDX STKPNTR
INX
LDA STACK,X
STA TEMP
INX
LDA STACK,X
STX STKPNTR
LDX TEMP
********************************
* PHX
* PHA
* PHX
* JSR $FDDA
* PLA
* JSR $FDDA
* PLA
* PLX
********************************
RTS
*
* Copy top of stack only
*
COPY LDX STKPNTR
INX
LDA STACK,X
STA TEMP
INX
LDA STACK,X
LDX TEMP
RTS
********************************
* End pseudo-stack code for string execute code
********************************
********************************
* Start unique number subroutines
********************************
*
* Initialize unique number
*
INITUNIQ LDA #100
STA UNIQUE
STZ UNIQUE+1
RTS
*
* Clear unique number largest
*
CLRUNIQ STZ LARGEST
STZ UNIQUSED
RTS
*
* Fetch unique number + index
*
FETUNIQ CMP LARGEST
BCC :SMALLER
STA LARGEST
:SMALLER CLC
ADC UNIQUE
TAX
LDA UNIQUE+1
ADC #00
SEC
ROR UNIQUSED
RTS
*
* Update unique number
*
UPDTUNIQ BIT UNIQUSED
BPL :NOTUSED
LDA UNIQUE
SEC
ADC LARGEST
STA UNIQUE
LDA UNIQUE+1
ADC #00
STA UNIQUE+1
:NOTUSED RTS
********************************
* End unique number subroutines
********************************
********************************
* Start program replacement string execute code
********************************
*
* Write a byte to output file
*
BYTEOUT STA (OUTDATA) ; Output data byte
********************************
* ORA #$80
* JSR COUT
********************************
INC OUTDATA ; Increment output pointer
BNE :SKIPINC
INC OUTDATA+1
:SKIPINC INC BYTES2 ; Increment # of bytes in buffer
BNE :SKPINC2
INC BYTES2+1
:SKPINC2 LDA BYTES2 ; Check to see if buffer is full...
CMP #WRITELEN
BNE :SKIPWRT
LDA BYTES2+1
CMP #/WRITELEN
BNE :SKIPWRT
JSR WRITEOUT ; If buffer is full then write it out
LDA #WRITEBUF ; Reset output data pointer
STA OUTDATA
LDA #/WRITEBUF
STA OUTDATA+1
STZ BYTES2 ; Clear number of bytes in buffer
STZ BYTES2+1
:SKIPWRT RTS
*
* Fetch parameters out of input text
*
GETPARMS LDX #02
LDY #$FF
:LOOP INY ; Scan for parameter flag
LDA (PNTR2),Y
CMP #$0D
BEQ :FINIS
CMP PARM
BNE :LOOP
LDA INPUT,Y ; Fetch value of parameter flag
STA REGISTER,X ; Store value in register
INX
STZ REGISTER,X
INX
BRA :LOOP
:FINIS RTS
*
* Execute operation code
*
EXEC_OP LDA (PNTR3),Y ; Fetch operation code
INY
CMP #'P' ; Check if it's a (P)arameter fetch
BNE :NOTP
LDA (PNTR3),Y
SEC
SBC #'0'
ASL
TAX
LDA REGISTER,X
STA FETCHED
LDA REGISTER+1,X
STA FETCHED+1
RTS
:NOTP CMP #'V' ; Check if it's con(V)ert parameter
BNE :NOTV
LDA (PNTR3),Y
SEC
SBC #'0'
ASL
TAX
LDA REGISTER,X
SEC
SBC #'0'
CMP #00
BCC :SETZERO
CMP #10
BCC :OK
:SETZERO LDA #00
:OK STA FETCHED
STZ FETCHED+1
RTS
:NOTV CMP #'L' ; Check if it's Literal command
BNE :NOTL
LDA (PNTR3),Y
STA FETCHED
STZ FETCHED+1
RTS
:NOTL CMP #'N' ; Check if it's Number command
BNE :NOTN
LDA (PNTR3),Y
SEC
SBC #'0'
STA FETCHED
STZ FETCHED+1
RTS
:NOTN CMP #'!' ; Check if it's copy & pop stack
BNE :NOTBANG
JSR POP
STX FETCHED
STA FETCHED+1
RTS
:NOTBANG CMP #'S' ; Check if it's copy top of Stack
BNE :NOTS
JSR COPY
STX FETCHED
STA FETCHED+1
RTS
:NOTS CMP #'U' ; Check if it's fetch Unique number
BNE :NOTU
LDA (PNTR3),Y
SEC
SBC #'0'
JSR FETUNIQ
STX FETCHED
STA FETCHED+1
RTS
:NOTU CMP #'H'
BNE :NOTH
LDA (PNTR3),Y
CMP #'9'+1
BCC :OKH
SBC #'A'-'9'
:OKH SBC #'0'-1
ASL
ASL
ASL
ASL
STA FETCHED
INY
LDA (PNTR3),Y
CMP #'9'+1
BCC :OKL
SBC #'A'-'9'
:OKL SBC #'0'-1
ORA FETCHED
STA FETCHED
STZ FETCHED+1
LDA #'C'
STA (PNTR3),Y
RTS
:NOTH CMP #'T'
BNE :NOTT
JSR MSGOUT
ASC "Trace on (?)",8D00
RTS
:NOTT PHA
JSR MSGOUT
ASC "Illegal operation code: ",A200
PLA
ORA #$80
JSR COUT
JSR MSGOUT
HEX A2
ASC " in string ",00
JSR PRINTI
JSR GETKEY
JMP BYE
*
* Execute dispose code
*
EXEC_DSP LDA (PNTR3),Y ; Fetch dispose code
CMP #'P' ; Parameter
BNE :NOTP
DEY
LDA (PNTR3),Y
SEC
SBC #'0'
ASL
TAX
LDA FETCHED
STA REGISTER,X
LDA FETCHED+1
STA REGISTER+1,X
RTS
:NOTP CMP #'S' ; Stack
BNE :NOTS
LDX FETCHED
LDA FETCHED+1
JMP PUSH
:NOTS CMP #'C' ; Character
BNE :NOTC
LDA FETCHED
JMP BYTEOUT
:NOTC CMP #'H' ; High
BNE :NOTH
LDA FETCHED+1
JMP BYTEOUT
:NOTH CMP #'N' ; Number
BNE :NOTN
LDY FETCHED
LDX FETCHED+1
********************************
STX TEMP
STZ TEMP3 ; Zero flag
LDX #$04
:OUTER STZ TEMP2 ; Current place value counter
:INNER INC TEMP2
TYA
SEC
SBC :DECPWRL,X
TAY
LDA TEMP
SBC :DECPWRH,X
STA TEMP
BCS :INNER
TYA
ADC :DECPWRL,X
TAY
LDA TEMP
ADC :DECPWRH,X
STA TEMP
DEC TEMP2
BNE :PRT
BIT TEMP3
BPL :SKIPPRT
:PRT LDA TEMP2
CLC
ADC #$30
JSR BYTEOUT
SEC
ROR TEMP3
:SKIPPRT DEX
BPL :OUTER
BIT TEMP3
BPL :ZERO
RTS
:ZERO LDA #'0'
JMP BYTEOUT
:DECPWRL DFB #1,#10,#100,#1000,#10000
:DECPWRH DFB #/1,#/10,#/100,#/1000,#/10000
********************************
:NOTN CMP #'+'
BNE :NOTPLUS
JSR POP
STA TEMP
TXA
CLC
ADC FETCHED
TAX
LDA TEMP
ADC FETCHED+1
JMP PUSH
:NOTPLUS CMP #'-'
BNE :NOTMINS
JSR POP
STA TEMP
TXA
SEC
SBC FETCHED
TAX
LDA TEMP
SBC FETCHED+1
JMP PUSH
:NOTMINS CMP #'*'
BNE :NOTMULT
JSR POP
STA TEMP2
TXA
ASL
ROL TEMP2
LDY TEMP2
PHY
PHA
ASL
ROL TEMP2
ASL
ROL TEMP2
STA TEMP
PLA
CLC
ADC TEMP
STA TEMP
PLA
ADC TEMP2
STA TEMP2
LDA TEMP
CLC
ADC FETCHED
TAX
LDA TEMP2
ADC FETCHED+1
JMP PUSH
:NOTMULT PHA
JSR MSGOUT
ASC "Illegal dispose code: ",A200
PLA
ORA #$80
JSR COUT
JSR MSGOUT
HEX A2
ASC " in string ",00
JSR PRINTI
JSR GETKEY
JMP BYE
*
* Execute caret command
*
EXEC_CRT JSR EXEC_OP ; Execute operation code
LDY #03
JMP EXEC_DSP ; Execute dispose code
*
* Execute replacement string
*
EXECSTR LDA PNTR3 ; Check for no replacement string
ORA PNTR3+1
BEQ :FINIS
:LOOP LDY #00
LDA (PNTR3),Y
BEQ :FINIS
********************************
* PHA
* LDA #"("
* JSR COUT
* LDA PNTR3+1
* JSR $FDDA
* LDA PNTR3
* JSR $FDDA
* LDA #")"
* JSR COUT
* LDA (PNTR3)
* ORA #$80
* JSR COUT
* LDA #$A0
* JSR COUT
* PLA
********************************
INY
CMP #'^' ; Check if it's caret command
BNE :NOT_CRT
JSR EXEC_CRT
LDA PNTR3
CLC
ADC #04
STA PNTR3
BCC :LOOP
INC PNTR3+1
BRA :LOOP
:NOT_CRT CMP #'@' ; Check if it's verbatim character output
BNE :NOTVERB
LDA (PNTR3),Y
JSR BYTEOUT
BRA :INC2
:NOTVERB CMP #';' ; Check for end-line character
BNE :NOT_EL
BIT NEWLN
BPL :INC1
LDA #$0D
JSR BYTEOUT
BRA :INC1
:NOT_EL CMP #$0D ; Don't print out CR between strings
BEQ :INC1
JSR BYTEOUT ; Output it verbatim
BRA :INC1
:INC2 INC PNTR3
BNE :INC1
INC PNTR3+1
:INC1 INC PNTR3
BNE :LOOP
INC PNTR3+1
BRA :LOOP
:FINIS RTS
********************************
* End program replacement string execute code
********************************
*
* Get a byte from program file
*
GETBYTEP LDA BYTES ; Check if there are still bytes
ORA BYTES+1 ; left to be read in buffer
BNE :NOTLOAD
BIT EOF ; If we hit EOF already then there
BMI :EOF ; are no more bytes to read
PHY
JSR READPROG ; otherwise read more of file
PLY
:NOTLOAD LDA BYTES ; Decrement bytes in buffer
BNE :SKIPDEC
DEC BYTES+1
:SKIPDEC DEC BYTES
LDA (INDATA) ; Fetch a byte and increment input pointer
AND #$7F
********************************
* PHA
* ORA #$80
* JSR $FDED
* PLA
********************************
INC INDATA
BNE :SKIPINC
INC INDATA+1
:SKIPINC SEC ; Return valid byte read
RTS
:EOF CLC ; No more bytes to read
RTS
*
* Get string of program file
*
GETSTRP LDY #00 ; Fetch first character
:LOOP JSR GETBYTEP
BCC :EOF
CMP IGNORE ; Ignore "ignore" character
BEQ :LOOP
CMP #$0D ; Refetch null input
BEQ :LOOP
CMP ENDLINE ; If it's a newline then it's
BEQ :WAITCR ; a comment line
STA INPUT ; Store first character
:LOOP2 JSR GETBYTEP ; Fetch successive characters
INY ; until CR
STA INPUT,Y
CMP ENDLINE
BEQ :WAITCR
CMP #$0D
BNE :LOOP2
SEC
RTS
:WAITCR JSR GETBYTEP ; Wait for a CR
BCC :EOF
CMP #$0D
BNE :WAITCR
STA INPUT,Y
TYA
BEQ :LOOP
SEC
:EOF RTS
*
* Read in & compile program file
*
DOPROG JSR OPENPROG ; Open program file
JSR OPENOUT ; Open output file
STZ BYTES2 ; Output buffer is empty
STZ BYTES2+1
JSR READPROG ; Initial read of program file
********************************
JSR CLRR
********************************
JSR INITSTCK ; Initialize stack
JSR INITUNIQ ; Initialize unique number
:LOOP JSR CLRUNIQ ; Clear unique largest
JSR GETSTRP ; Get string of program file
BCC :EOF
STY LENGTH
********************************
* JSR DEBUG1
********************************
JSR FINDNODE ; Find matching template
BCC :ERROR
JSR GETPARMS
********************************
* JSR DEBUGP
********************************
********************************
* JSR DEBUG3
********************************
JSR EXECSTR
********************************
* JSR DEBUGP
********************************
JSR UPDTUNIQ ; Update unique if necessary
BRA :LOOP
:ERROR JSR MSGOUT
ASC "No matching template for ",00
JSR PRINTI
:EOF JSR CLOSEPRG ; Close open files
JSR WRITEOUT
JSR CLOSEOUT
JMP BYE
********************************
********************************
* End program file subroutines
********************************
********************************
*
* Get filenames
*
GETFN LDA #06
STA CV
JSR BASCALC
LDA #20
STA CH
JSR MSGOUT
ASC " Macro filename: ",00
JSR GETLN
STY FILE1
:LOOP LDA INPUT-1,Y
STA FILE1,Y
DEY
BNE :LOOP
LDA #07
STA CV
JSR BASCALC
LDA #20
STA CH
JSR MSGOUT
ASC "Program filename: ",00
JSR GETLN
STY FILE2
:LOOP2 LDA INPUT-1,Y
STA FILE2,Y
DEY
BNE :LOOP2
LDA #08
STA CV
JSR BASCALC
LDA #20
STA CH
JSR MSGOUT
ASC " Output filename: ",00
JSR GETLN
STY FILE3
:LOOP3 LDA INPUT-1,Y
STA FILE3,Y
DEY
BNE :LOOP3
RTS
*
* Main routine
*
MAIN LDA #$A0 ; Clear screen
JSR HOME
LDA #02
STA CV
JSR BASCALC
LDA #30
STA CH
JSR MSGOUT
ASC "Pidgin compiler v1.0",00
LDA #04
STA CV
JSR BASCALC
LDA #30
STA CH
JSR MSGOUT
ASC "by Toshiyasu Morita",00
JSR GETFN
JSR MSGOUT
HEX 8D
ASC "Processing macros file...",8D00
JSR DOMACROS ; Read in & sort macro file
JSR MSGOUT
ASC "Macros file done.",8D8D
ASC "Processing program file...",8D00
JSR DOPROG
JSR MSGOUT
ASC "Program file done.",8D00
BYE JSR MSGOUT
ASC "Press any key: ",00
JSR GETKEY
JSR MLI
DFB $65
DW :PARMS
:PARMS DFB 4
HEX 00
HEX 0000
HEX 00
HEX 0000
********************************
* Start debug stuff
********************************
DEBUG1 LDA #"R"
BIT TEMPLATE
BPL :SKIP
LDA #"T"
:SKIP JSR COUT
LDA LENGTH
JSR $FDDA
LDA #" "
JSR COUT
LDY #$FF
:LOOP INY
LDA INPUT,Y
PHA
JSR COUT
PLA
CMP #$0D
BNE :LOOP
RTS
DEBUG2 LDY #$FF
:LOOP INY
LDA (PNTR2),Y
PHA
JSR COUT
PLA
CMP #$0D
BNE :LOOP
RTS
DEBUG3 LDA PNTR3+1
JSR $FDDA
LDA PNTR3
JSR $FDDA
LDA #" "
JSR COUT
LDA PNTR3
ORA PNTR3+1
BEQ :FINIS
LDY #$FF
:LOOP INY
LDA (PNTR3),Y
BEQ :FINIS
JSR COUT
BRA :LOOP
:FINIS RTS
CLRR LDX #19 ; Clear registers
:LOOP STZ REGISTER,X
DEX
BPL :LOOP
RTS
DEBUGP LDY #$00
:LOOP LDA REGISTER,Y
STA :JUNK
INY
LDA REGISTER,Y
PHY
JSR $FDDA
LDA :JUNK
JSR $FDDA
LDA #" "
JSR COUT
PLY
INY
CPY #20
BNE :LOOP
LDA #$8D
JMP COUT
:JUNK HEX 00
********************************
* End debug stuff
********************************
ENDPROG DS \
*
* ProDOS file buffers - $400 apiece
*
IFILEBUF EQU *
OFILEBUF EQU IFILEBUF+$400
STACK EQU OFILEBUF+$400
HASHTBLL EQU STACK+$100
HASHTBLH EQU HASHTBLL+8
REGISTER EQU HASHTBLH+8 ; Pseudo-registers (10 of 2 bytes each)
FREEAREA EQU REGISTER+20
TYP $FF
SAV PIDGIN.SYSTEM