Received: by NDSUVM1 (Mailer R2.07) id 0209; Tue, 21 Aug 90 21:18:19 CDT
Date:         Tue, 21 Aug 90 22:14:10 EDT
Reply-To:     Apple II List <APPLE2-L@BROWNVM.BITNET>
Sender:       Apple II List <APPLE2-L@BROWNVM.BITNET>
From:         Grant Delaney <delaneyg@wnre.aecl.ca>
Subject:      PIDGIN.S
To:           "Steven E. Nelson" <CMDSENPG@UIAMVS.BITNET>

From: tm@polari.uucp

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

