*===============================              -*- Mode: Merlin -*-
* Executioner (EXEC file maker)
*   Glen E. Bredon  Dec 24, 86
*-------------------------------

 DATE
 TR ADR
 TR
 EXP OFF

SAVOBJ KBD

* Data

LINSTART = #"."

;This is the character at start of
;each line, but not checked for.
;This is simply to avoid the possibility
;of a DOS command at the beginning of a line.

* Usage by this program:

FPNT = $D0 ;Pointer to catalog entry
LEN = $D2 ;For reading directory
ENTPER = LEN+1 ; "
THISCNT = $D4 ; "
NL = $D5 ;PRDEC usage
NH = $D6 ; "
NFL = $D7 ; "
BASFLAG = $D8 ;Flags basic program
MAXLEN = $D9 ;Count for len of basic prog
PFLAG = $DB ;Flags extra 6-bit packing
ADD0 = $DC ;Used to compute expansion
ADD1 = $DD ; factor at end
ADD2 = $DE
PNT = $E0 ;Pointer to code
TEMP = $E2 ;For 6-bit unpacker only
FLAG = $E3 ;Misc use
ADRS = $E2 ;For line header
TXTP = $E4 ;For SENDMSG
CNT = $E6 ;Count up for len of code
SLASHFLG = $E8 ;Disable slash on file name
BUFPNT = $E9 ;Pointer into 1 pg wrt buf
YSAV = $EA
COUNT = $EB ;& C,D: size of EXEC file
LINLEN = $EE ;# of bytes on each line
PACKFLG = $EF ;+ if ord, V set if 6-bit
THREE = $F0 ;Count (-) for three bytes
XSAV = $F1
BYT0 = $F2 ;Temp storage when packing
BYT1 = $F3
BYT2 = $F4
BYT3 = $F5
STARTFLG = $F6 ;Flags initial entry
SIZ0 = $F7 ;Used to compute exp factor
SIZ1 = $F8
CHKSUM = $FF ;Used only in packing modes

LOADADR = $1000 ;Start adrs written to file
FILEBUF = $1000 ;Buffer for our file write
WBUF = $1800 ;1 page buffer for writing
CATBUF = $1C00 ;1 block needed for this
PROGBUF = $3000 ;Source file load adrs
FILES = $8000 ;Catalog entry list

* Apple stuff:

CH = $24
CV = $25
IN = $200
DOSWARM = $3D0
RESET = $3F2
MLI = $BF00
DEVNUM = $BF30
BITMAP = $BF58
ALTCHRS = $C00F
SPEAKER = $C030
TOKENS = $D0D0 ;Applesoft token table
TABV = $FB5B
CLREOP = $FC42
HOME = $FC58
WAIT = $FCA8
RDKEY = $FD0C
GETLNZ = $FD67
CROUT = $FD8E
PRBYTE = $FDDA
COUT = $FDED
MONITOR = $FF69

* MLI call codes:

quit = $65
create = $C0
destroy = $C1
setinfo = $C3
getinfo = $C4
online = $C5
setpfx = $C6
getpfx = $C7
open = $C8
read = $CA
write = $CB
close = $CC
seteof = $D0
geteof = $D1

*===============================

STADR MAC
 LDA #]1
 STA ]2
 LDA #>]1
 STA ]2+1
 <<<

INCD MAC
 INC ]1
 BNE NI
 INC ]1+1
NI <<<

MOVD MAC
 LDA ]1
 STA ]2
 LDA ]1+1
 STA ]2+1
 <<<

DOS MAC
 JSR MLI
 DFB ]1
 DA ]2
 <<<

WRITE MAC
 LDX ]1
 LDY #0
LUP INY
 LDA ]1,Y
 JSR WRTBYTE
 DEX
 BNE LUP
 <<<

*===============================

 TYP $FF ;Make SYS file
 ORG $2000

 JMP START0

 HEX EEEE ;STARTUP signature

 DFB $40 ;Its max length

STARTUP DS $40 ;Prefix (etc) for dest file

*------------------------------------
* File type names (followed by type).
* Change the "NON" ones to add types.
*------------------------------------

TYPES ASC "BAD"01
 ASC "TXT"04
 ASC "BIN"06
 ASC "DIR"0F
 ASC "ADB"19
 ASC "AWP"1A
 ASC "ASP"1B
 ASC "S16"B3
 ASC "NDA"B8
 ASC "CDA"B9
 ASC "TOL"BA
 ASC "DOC"BF
 ASC "PNT"C0
 ASC "PIC"C1
 ASC "FON"C8
 ASC "CMD"F0
 ASC "LNK"F8
 ASC "BAS"FC
 ASC "VAR"FD
 ASC "REL"FE
 ASC "SYS"FF
 LUP 11
 ASC "NON"00
 --^
TYPEND ERR *-TYPES/$84

START0 LSR STARTFLG ;Signal initial entry
START STADR EXIT  ;RESET      ;Set up RESET vector
 EOR #$A5
 STA RESET+2
 LDX #$17
 LDA #1
]LUP STA BITMAP,X ;Min bit map (we will do
 LDA #0  ; the worrying).
 DEX
 BPL ]LUP
 TXS
 LDX #$11  ;Blank filename in case
]LUP STA FILENAME-1,X ;of multiple use
 DEX
 BNE ]LUP
 STA PFLAG  ;Init extra packing flag
 STA BUFPNT  ; and buffer ptr
 STA COUNT+1
 STA COUNT+2
 STA PACKFLG  ; and packing flag off
 STA THREE  ; and set 0 mod 3
 LDA #%11001111
 STA BITMAP
 LDA #"U"&$9F ;Turn on 40 columns
 JSR COUT
 JSR HOME
 STA ALTCHRS  ;Enable mousetext
 JSR WIRE  ;Print barbed wire
 JSR CROUT
 LDX #14
 JSR SENDEXEC ;Print EXEC
 LDX #2
 BIT STARTFLG
 BMI :LUP
 LDX #20
:LUP TXA
 JSR TABV
 LDA #19
 STA CH
 JSR SENDUT  ;Print UTIVE on this line
 LDY #40  ; & wipe from next
:WIP LDA #" "
 JSR COUT
 DEY
 BNE :WIP
 TYA
 JSR WAIT
 DEX
 CPX #2
 BGE :LUP  ;Branch till it is on top
 LDA #3
 STA CNT
 LDA #2
 JSR TABV
 BIT STARTFLG
 BMI :OVER  ;Skip if not initial entry
:CLOOP LDX #14
:CLACK JSR CLACK  ;Move words out
 DEX
 CPX #4
 BGE :CLACK  ;Till this point
:BACK INX
 JSR CLACK  ;Move them back together
 CPX #14
 BLT :BACK
 LDX #$30
:CLICK BIT SPEAKER  ;Make a noise
 LDY #$C0
:PAUSE INY
 BNE :PAUSE
 DEX
 BNE :CLICK
 DEC CNT
 BNE :CLOOP  ;Repeat twice more
:OVER LDA #7
 STA CH
 JSR SENDMSG
 ASC "By Glen"00
 LDA #27
 STA CH
 JSR SENDMSG
 ASC "Bredon"8d8d
 ASC "Produces an EXEC text file from any"
 HEX 8D
 ASC "ProDOS file."8d8d
 ASC "Packed format?"00
 JSR YORN
 STA STARTFLG
 ROR PACKFLG  ;- if packing wanted
 BPL :STD  ;Skip if no packing
 LDA #6
 JSR TABV
 JSR SENDMSG
 HEX 8D
 ASC "4 bit (HEX) or 6 bit packing? (4/6):"
 BRK
:KY JSR RDKEY
 CMP #"6"
 BEQ :RR
 CMP #"4"
 BNE :KY
 CLC
:RR JSR PUSHOUT
 BCC :STD
 LDA #%11000000 ;Signal 6-bit packing mode
 STA PACKFLG  ; by V flag
:STD JSR SENDMSG
 HEX 8D8D
 ASC "Prefix: "00
 DOS getpfx  ;PFXPARMS
 BCS :BMLIERR
 LDX IN+$40
 BEQ :INPUT  ;Branch if no pfx
:PPF INY
 LDA IN+$40,Y
 STA IN-1,Y
 ORA #$80
 JSR COUT  ;Show prefix
 DEX
 BNE :PPF
 LDX IN+$40
:INPUT JSR INPUT0  ;Get new pfx
 BEQ :JEX  ;Abort if pfx erased
 STX IN+$40
:MOVP LDA IN-1,X
 STA IN+$40,X
 DEX
 BNE :MOVP
 DOS setpfx  ;PFXPARMS
:BMLIERR BCS :DMLIERR
 JSR CAT  ;Read the catalog
 JSR SENDMSG  ; according to prefix
 HEX 8D8D
 ASC "File to convert: "00
 LDX #-1
 STX SLASHFLG ;Disallow slash and input
 INX   ; at most 15 chars
 JSR PRFILE  ;Start with last cat entry,
 JSR INPUT  ; note this zeros COUNT
 BNE :ON
:JEX JMP EXIT  ;Abort if name erased
:ON STX IN+$80
 STX FILENAME
:MOV LDA IN-1,X
 STA IN+$80,X ;Set name for getinfo etc
 STA FILENAME,X ;Save inside EXEC file
 DEX
 BNE :MOV
 DOS getinfo  ;INFPARMS
:DMLIERR BCS :MLIERR
 LDA #$4A  ;Incompat format error
 LDX INFTYPE
 CPX #$F
 BEQ :MLIERR  ;Error if a directory
 STADR IN+$80  ;OPATH
 JSR OPEN  ;Open the source file
 DOS geteof  ;EOFPARMS
 BCS :MLIERR  ; and get its length
 LDX #PARMEND-PARMS-1
:MVP LDA INFPARMS,X
 STA PARMS,X  ;Save its info in EXEC
 DEX   ; file for setinfo call
 CPX #ACC-PARMS
 BGE :MVP
 LDA EOF+2
 STA ZERO  ;Zero out the three
 STA ZERO+1  ; unused info bytes
 STA ZERO+2
 BNE :TOOBIG  ;Carry is clear
 LDA EOF
 STA SIZ0
 STA RWCNT
 STA PNT
 LDA EOF+1
 STA SIZ1
 STA RWCNT+1
 ADC #>PROGBUF
 STA PNT+1
 LDA #$8200
 CMP EOF
 LDA #>$8200
 SBC EOF+1
:TOOBIG BLT TOOBIG
 JSR SHOWSPEC ;Show file info and
 BLT :START  ; restart if not ok
 STADR PROGBUF  ;RWBUF
 DOS read  ;RWPARMS   ;Load the file
 BCS :MLIERR
 DOS close  ;CLSPARMS
:MLIERR BCS MLIERR
 LDA #$61  ;Mark end of file for
 LDY #0  ; packing routines
 STA (PNT),Y
 JSR CNTPACK
 JSR GETDEST  ;Ask for dest filename
 BEQ EXIT
 STX IN+$C0
:MOVD LDA IN-1,X
 STA IN+$C0,X
 DEX
 BNE :MOVD
 JSR MAKEFILE ;Write the EXEC file
 BCC EXIT
:START JMP START

EXIT DOS close  ;CLSPARMS
 DOS quit  ;QPARMS
 BRK

*=============================
* MLI error handling and quit:
*-----------------------------

TOOBIG LDA #$FF  ;Fake err code
MLIERR PHA
 PHA
 DOS close  ;CLSPARMS
 JSR SENDMSG
 HEX 8D8D
 ASC "MLI error: $"00
 PLA
 JSR PRBYTE  ;Print error code
 JSR CROUT
 PLA
 LDX #ERREND-ERRORS
:CERR DEX
 BMI HIT  ;Skip if err code not in tbl
 CMP ERRORS,X
 BNE :CERR
 LDY ERROFF,X
:PERR LDA ERRORS,Y
 BEQ HIT
 JSR COUT  ;Print error message
 INY
 BNE :PERR
HIT JSR SENDMSG
 HEX 8D8D
 ASC "Hit a key"8d00
 JSR RDKEY
JSTART JMP START

*===============================
* Routine to create dest file,
* and call file converter.
*-------------------------------

MAKEFILE STADR IN+$C0 ;OPATH
 DOS create  ;CREPARMS
 BCC :OK  ;Skip if file created ok
 CMP #$47  ;Duplicate file
 BNE MLIERR  ;Error if not
 JSR SENDMSG
 HEX 8D8D
 ASC "File exists, delete it?"00
 JSR YORN
 BCC JSTART  ;Restart if N
 DOS destroy  ;DESPARMS
 BCC MAKEFILE ;Else create it
:MLIERR JMP MLIERR  ;Error if locked, etc
:OK JSR OPEN  ;Open destination file
 JSR WRTFILE  ;Write data to it and close
 DOS close  ;CLSPARMS
 BCS :MLIERR
 TAX   ;=0
 LDY #3
:DOUB LDA COUNT,X  ;Double size
 ROL
 STA BYT0,X  ; and save it
 STA ADD0,X
 INX
 DEY
 BNE :DOUB
 DEX   ;=2
:MUL ASL ADD0  ;Multiply ADD by 4
 ROL ADD1  ; = size x 8
 ROL ADD2
 INY
 DEX
 BNE :MUL
:ADD LDA ADD0,X  ;Add size x 8 to
 ADC BYT0,X  ; size x 2 to get
 STA BYT0,X  ; size x 10
 INX
 DEY
 BPL :ADD
 LDA SIZ1  ;Add (orig size)/2
 LSR   ; to size x 10 for
 TAX   ; rounding final factor
 LDA SIZ0
 ROR
 ADC BYT0
 STA BYT0
 TXA
 ADC BYT1
 STA BYT1
 BCC :PER
 INC BYT2
:PER LDA BYT0  ;Divide this by orig size
 SBC SIZ0  ; (don't bother setting
 STA BYT0  ; carry at entry - this is
 LDA BYT1  ; only an approx anyway.
 SBC SIZ1  ;Division done by repeated
 STA BYT1  ; subtraction (quotient
 LDA BYT2  ; cannot be more than
 SBC #0  ; about 40).
 STA BYT2
 INY   ;Count quotient in Y
 BGE :PER
 TYA
 PHA   ;Exp factor x10
 JSR HOME
 JSR SENDMSG
 HEX 8D8D8D8D00
 JSR WIRE  ;Start a wire box
 JSR DWNARROW ;line 2
 ASC 'K'
 ASC " EXEC file length = $"00
 LDA COUNT+2
 BEQ :SKP
 JSR PRBYTE
:SKP LDA COUNT+1
 JSR PRBYTE  ;Print length
 LDA COUNT
 JSR PRBYTE
 JSR UPARROW
 JSR DWNARROW
 ASC 'K'
 ASC " Expansion factor = "00
 PLA
:LX0 LDX #0
:C10 CMP #10  ;Divide exp factor by 10
 BLT :DIVD
 SBC #10
 INX   ; quotient in X
 CPX #10
 BLT :C10
 INY
 BGE :LX0
:DIVD PHA   ;Save remainder
 TYA
 BEQ :LESS
 ORA #"0"
 JSR COUT
:LESS TXA
 ORA #"0"
 JSR COUT  ;Print integer part
 LDA #"."
 JSR COUT
 PLA
 ORA #"0"
 JSR COUT  ; and tenths
 JSR UPARROW
 BIT BASFLAG
 BPL :NOBAS  ;Skip if not basic
 JSR DWNARROW
 ASC 'K'
 ASC " Longest line length = "00
 STY BASFLAG  ;Fix so WRTDEC uses COUT
 LDA MAXLEN+1
 LDX MAXLEN
 JSR WRTDEC  ;Print max line length
 JSR UPARROW
:NOBAS JSR DWNARROW
 ASC 'K'
 ASC " Another?"00
 JSR UPARROW
 JSR DWNARROW
 ASC 'K'00
 JSR UPARROW
 JSR WIRE
 LDA CV
 SEC
 SBC #4
 JSR TABV  ;Position cursor for YORN
 LDA #10
 STA CH
 JMP YORN  ;Exit through YORN

WIRE JSR :DIAM  ;Print diamond
 LDX #19
:TOP JSR SENDMSG  ;Print barbed wire
 ASC 'UH'00
 DEX
 BNE :TOP  ; then another diamond
:DIAM LDA #'['
 JMP COUT

DWNARROW JSR SENDMSG ;Print down arrows at
 ASC 'J'00
 LDA #39  ; both ends of line
 STA CH
 LDA #'J'
 JSR COUT
 JMP SENDMSG  ;Fall into SENDMSG

UPARROW LDA #39  ;Print up arrow at right
 STA CH  ; side of screen
 LDA #'K'
 JMP COUT

OPEN DOS open  ;OPARMS
 BCS :MLIERR
 LDA OREF
 STA EOFREF
 STA RWREF
 RTS

:MLIERR JMP MLIERR

TIMER LDA #'C'  ;Hourglass
 STA $502
 STA $525
 RTS

*============================================
* Routines that actually write the EXEC file.
*--------------------------------------------

WRTFILE STADR $100  ;RWCNT    ;Set to write one page buf
 STADR WBUF  ;RWBUF
 LDA INFTYPE
 CMP #$FC  ;BAS file type
 BNE :NOTBAS
 JSR SENDMSG
 HEX 8D8D
 ASC "Original is a BASIC program, do you"8D
 ASC "want a listing type EXEC file?"00
 JSR YORN
 BCC :NOTBAS
 ROR BASFLAG
 JMP MAKBAS  ;Go with Y=0
:NOTBAS JSR TIMER
 WRITE CALL  ;Write CALL-151
 LDY #0
 STY CHKSUM
 STY ADRS
 LDA #>$E00
 STA ADRS+1  ;Write setinfo header
:HEAD JSR WRTADR0  ;Write line header
 LDX #$18  ;Count for $18 bytes
:HLUP LDA SETINF,Y
 JSR WRTHEX2  ;Write one hex byte
 DEX
 BEQ :LIN
 LDA SETINF,Y
 BNE :CONT
 CPY #FILENAME-SETINF
 BGE HEAD2
:CONT JSR WRTSPC  ;Space after byte
 INY
 BNE :HLUP  ;Always
:LIN LDA SETINF,Y
 BNE :ON
 CPY #FILENAME-SETINF
 BGE HEAD2
:ON LDA ADRS  ;Next line
 CLC
 ADC #$18
 STA ADRS
 INY
 BNE :HEAD  ;Always (less that 1 page)

HEAD2 BIT PACKFLG
 BPL :HDONE  ;Skip if no packing
 LDY #0
 STY ADRS
 LDA #>$F00
 STA ADRS+1  ;Write unpacker header
 STADR READSQZ  ;PNT
 BVC :HEAD  ;Branch if 4-bit mode
 STADR RS6  ;PNT
 BIT PFLAG
 BPL :HEAD  ;Branch for standard 6-bit
 STADR RS6P  ;PNT
:HEAD JSR WRTADR0  ;Write line header
 LDX #$18  ;Count for $18 bytes
:HLUP LDA (PNT),Y
 BNE :WRIT
 INY
 LDA (PNT),Y  ;Check for 2-0s end mark
 BEQ :F00G
 DEY
 LDA (PNT),Y
:WRIT JSR WRTHEX2  ;Write one hex byte
 INY
 INY
 LDA (PNT),Y
 DEY
 DEX
 BEQ :LIN
 ORA (PNT),Y
 BEQ :F00G
 JSR WRTSPC  ;Space after byte
 JMP :HLUP
:LIN ORA (PNT),Y  ;Check end mark
 BEQ :F00G
 LDA ADRS  ;Next line
 CLC
 ADC #$18
 STA ADRS
 BCC :HEAD  ;Always
:F00G JSR WRTCR
 WRITE F00G
:HDONE STADR LOADADR  ;ADRS   ;Set to write code
 STADR PROGBUF  ;PNT  ;Actual code adrs
 LDA #$18
 STA LINLEN  ;24 bytes for ord dump
 LDA EOF
 EOR #$FF
 STA CNT  ;Calculate for count up
 LDA EOF+1
 EOR #$FF
 STA CNT+1
 INCD CNT
 BEQ :DONE  ;Safety if no file
:LINLUP BIT PACKFLG
 BPL :WAD
 LDA #$20  ;32 bytes/line if pack-4
 BVC :SL
 LDA #$30  ;48 if pack-6
:SL STA LINLEN
 JSR WRTCR
 BIT PACKFLG
 BVC :NOADR
 LDA #LINSTART
 JSR WRTBYTE  ;Avoid DOS commands
 JMP :NOADR
:WAD JSR WRTADR  ;Write line header
:NOADR LDX LINLEN  ;Count for $18/20/30 bytes
:LUP LDY #0
 LDA (PNT),Y
 EOR CHKSUM
 STA CHKSUM
 LDA (PNT),Y
 CMP #$61
 BEQ :WH  ;Skip pack if endmark chr
 BIT PACKFLG
 BVC :WH  ; or 4-bit or std mode
 BIT THREE
 BMI :WH  ; or 4 byte packet undone
 BIT PFLAG
 BPL :WH  ; or std 6-bit mode.
:IY INY
 BMI :DOIT
 CMP (PNT),Y  ;Check for repetitions
 BEQ :IY
:DOIT DEY   ;Max $7F
 TYA
 CMP #3
 BLT :WH  ;Skip if < 4 reps
 JSR PACKBYTS ;Make packed packet
 BCS :DONE
 BCC :DX
:WH LDY #0
 LDA (PNT),Y
 JSR WRTHEX  ;Write one byte
 INCD CNT
 BEQ :DONE  ;Exit when code done
 INCD ADRS  ;Bump fake adrs
 INCD PNT  ; and actual adrs
:DX DEX
 BEQ :LINLUP  ;Branch if new line
 BIT PACKFLG
 BMI :LUP
 JSR WRTSPC  ;Else write space
 JMP :LUP

:DONE BIT PACKFLG
 BPL :NOCHK
 LDA CHKSUM  ;Write checksum if packed
 JSR WRTHEX
:NOCHK JSR WRTCR
 BIT PACKFLG
 BPL :FIN
 JSR WRTCR  ;Empty line if packed
:FIN WRITE BSAVE  ;Write BSAVE
 WRITE IN+$80  ; and filename
 WRITE AD  ; and A parameter, etc
 LDA EOF+1
 JSR WRTHEX2  ;Write L parameter
 LDA EOF
 JSR WRTHEX2
 JSR WRTCR  ;CR
 BIT PACKFLG
 BPL :C3
 WRITE CALL2  ;Write E00G if packed
 JMP FINISH
:C3 WRITE CALL3  ;Write E05G if not packed
FINISH JSR WRTCR
 LDA BUFPNT  ;If buffer done, skip
 BEQ :RET  ; else write it
 JSR WRTBUF
 LDX #2
:CL LDA COUNT,X  ; and set correct length
 STA EOF,X
 DEX
 BPL :CL
 DOS seteof  ;EOFPARMS
 BCS ERR
:RET RTS

WRTADR0 JSR WRTCR
 LDA ADRS+1
 JSR WRTNIB
 JMP WA2
WRTADR JSR WRTCR  ;Write line header
 LDA ADRS+1
 JSR WRTHEX2
WA2 LDA ADRS
 JSR WRTHEX2
 LDA #":"
 BNE WRTBYTE

WRTHEX BIT PACKFLG
 BVC WRTHEX2  ;Branch if not pack-6
 STX XSAV
 PHA
 LDX THREE  ;Take abs val of count
 TXA
 EOR #-1
 TAX
 INX   ; use as index to temp bytes
 PLA
 ASL   ;Shift off top two bits &
 PHP   ; put into BYT0
 ASL
 ROR BYT0
 PLP
 ROR BYT0
 STA BYT1,X  ;Store byte*4 in BYT1,2,3
 CPX #2
 BEQ :OFF
 LDX XSAV  ;Exit if have not processed
 DEC THREE  ; all three bytes
 RTS
:OFF LDX #6  ;Reverse the order of the
 LDA #0  ; six bits in BYT0
:SHFT ASL BYT0
 ROR
 DEX
 BNE :SHFT
 STA BYT0  ;They are now in high-low
 STX THREE  ; order with 1st one at
:SEND LDA BYT0,X  ; top
 LSR
 LSR
 CLC
 ADC #$3F
 JSR WRTBYTE  ;Write to file.
 INX
 CPX #4
 BLT :SEND  ;Send all 4 bytes
 LDX XSAV
 RTS

ERR JMP MLIERR

WRTHEX2 PHA   ;Write hex byte
 LSR
 LSR
~ LSR
 LSR
 JSR WRTNIB
 PLA
 AND #$F
WRTNIB ORA #"0"
 CMP #"9"+1
 BLT WRTBYTE
 ADC #6
 HEX 2C
WRTCR LDA #$8D
 BIT PACKFLG  ;If not 6-bit packed
 BVC WRTBYTE  ; then write CR
 BIT THREE  ;Same if #=0 mod 3
 BPL WRTBYTE
 LDA #0  ;Else write 0s until it is
 JSR WRTHEX
 JMP WRTCR  ;Loop while # not 0 mod 3

WRTSPC LDA #" "
WRTBYTE AND #$7F  ;Write (pos) ascii byte
 STY YSAV
 LDY BUFPNT
 STA WBUF,Y  ;Wait for 1 page before
 LDY YSAV  ; sending to MLI
 INC COUNT  ;Count EXEC file size
 BNE :IB
 INC COUNT+1
 BNE :IB
 INC COUNT+2
:IB INC BUFPNT  ;Fall into WRTBUF if
 BNE RTN  ; buffer full
WRTBUF DOS write  ;RWPARMS
 BCS ERR
RTN RTS

PACKBYTS LDA #"0"
 JSR WRTBYTE  ;Write special signature
 LDA (PNT),Y
 AND #%11
 CLC
 ADC #$3F
 JSR WRTBYTE  ;Low two bits
 LDA (PNT),Y
 EOR CHKSUM
 STA CHKSUM  ;Correct checksum
 LDA (PNT),Y
 LSR
 LSR
 CLC
 ADC #$3F
 JSR WRTBYTE  ;Upper six bits
 DEY
 TYA
 LSR   ;Max $7E/2 = $3F
 CLC
 ADC #$3F
 JSR WRTBYTE  ;Length of segment/2-1
 INY
 INY
 TYA
 LSR   ;Always even
 ASL   ;Clears carry
 TAY   ;Length of segment
 ADC CNT  ;Bump pointers
 STA CNT
 BCC :ON
 INC CNT+1
 BEQ :RET  ;Carry set this exit
 CLC
:ON TYA
 ADC PNT
 STA PNT
 BCC :DX
 INC PNT+1
 CLC   ;Signal more to do
:DX DEX
 DEX
:RET RTS

*===============================
* Routine to count repetitions
* to decide packing mode
*-------------------------------

CNTPACK BIT PACKFLG  ;Ignore if not in 6-bit mode
 BVC :RET
 LDX #0
 STX FPNT
 LDA #>PROGBUF
 STA FPNT+1
:NXCNT LDY #0
 LDA (FPNT),Y ;Get a byte
:LUP INY
 BMI :SETFLG  ;Pack if 128 byte segment
 CMP #$61  ;Ignore end mark char
 BEQ :SY
 CMP (FPNT),Y
 BEQ :LUP  ;Loop if same as last
:SY STY YSAV  ;= length of segment
 CPY #8  ;Ignore if short
 BLT :OV
:TYX DEY   ;Transfer Y to running
 BEQ :OV  ; counter in X
 INX
 BPL :TYX  ;If total>127 then pack
:SETFLG SEC   ;Signal extra packing mode
 ROR PFLAG
:RET RTS
:OV LDA YSAV  ;Bump pointer past segment
 CLC
 ADC FPNT
 STA FPNT
 BCC :DONE
 INC FPNT+1
:DONE CMP PNT
 LDA FPNT+1
 SBC PNT+1
 BLT :NXCNT  ;Loop till prog done
 RTS

*============================
* Routine to write BASIC file
*----------------------------

MAKBAS JSR TIMER
 LDY #0
 STY PACKFLG  ;Defeat packing request
 STY LEN
 STY LEN+1
 STY MAXLEN
 STY MAXLEN+1
 STY PNT
 LDA #>PROGBUF
 STA PNT+1  ;Point to file
 WRITE NEW  ;Send "NEW"
 JSR WRTCR
:BASLUP LDA LEN  ;Set max if line length
 CMP MAXLEN
 LDA LEN+1
 SBC MAXLEN+1
 BLT :SHORT
 MOVD LEN  ;MAXLEN
:SHORT LDY #0
 STY LEN  ;Restart line len count
 STY LEN+1
 INY
 LDA (PNT),Y  ;Link hi
 BEQ :DONE  ;Done if link hi is zero
 INY
 LDA (PNT),Y  ;Line # low
 TAX
 INY
 LDA (PNT),Y  ; " hi
 JSR WRTDEC  ;Send line number
 LDA PNT  ;Point to 1st char of line
 CLC
 ADC #4
 STA PNT
 BCC :LINLUP
 INC PNT+1
:LINLUP LDY #0
 LDA (PNT),Y
 BEQ :ENDLIN  ;Branch on end of line
 BMI :ISTOK  ;Branch on token
:WRT JSR WRTBAS  ;Write non-token
:NXT INCD PNT  ;Point to next char
 BNE :LINLUP  ;Branch always

:ISTOK CMP #186  ;PRINT token?
 BNE :TOK
 LDA #'?'  ;Substitute "?"
 BNE :WRT
:TOK TAX   ;Tok in X for table lookup
 STADR TOKENS-1 ;FPNT
:DX DEX
 BPL :GOTTOK  ;Pointing to word in table
:LOOK INCD FPNT  ; when X goes positive
 LDA (FPNT),Y
 BEQ :ERR  ;Should not happen
 EOR TOKENS  ;Support for Laser-128
 BPL :LOOK  ;Branch if word not done
 BMI :DX  ;Count the word
:GOTTOK INCD FPNT  ;Point to next word
 LDA (FPNT),Y
 PHA
 JSR WRTBAS  ;Send it
 PLA
 EOR TOKENS  ;Support for Laser-128
 BPL :GOTTOK  ;Loop till word sent
 BMI :NXT  ;Then back to program

:ERR LDA #0  ;Illegal token, abort
 JMP MLIERR

:ENDLIN JSR WRTCR  ;End line with CR
 INCD PNT
 JMP :BASLUP  ;Next line

:DONE WRITE SAVE  ;Send "SAVE "
 WRITE IN+$80  ; and filename
 JMP FINISH  ; and go wind it up.

*======================================
* Line number printer for BASIC listing
*--------------------------------------

WRTDEC STA NH  ;Save #
 STX NL
 LDX #9  ;Loop count
 STX NFL  ; and table index
:LOAD0 LDY #"0"
:DIV LDA NL
 CMP :NUMTBL-1,X
 LDA NH
 SBC :NUMTBL,X ;Compare w power of 10
 BCC :DIVD  ;If less then have quot.
 STA NH
 LDA NL  ;Else subtract that power
 SBC :NUMTBL-1,X
 STA NL
 INY   ; count quotient
 BNE :DIV  ; and branch always
:DIVD TYA   ;Y has quotient in ascii
 DEX
 BEQ :PRD  ;Always write final digit
 CMP #"0"
 BEQ :PDIG
 STA NFL  ;Flag a nonzero digit
:PDIG BIT NFL
 BPL :NXDIG  ;Skip leading zeros
:PRD JSR WRTBAS0
:NXDIG DEX
 BPL :LOAD0
 RTS

:NUMTBL DA 1,10,100,1000,10000

WRTBAS0 BIT BASFLAG  ;If BASFLAG is +
 BMI WRTBAS
 JMP COUT  ; then print to screen
WRTBAS INCD LEN  ; else count the byte
 JMP WRTBYTE  ; and write to file

*===============================
* Routine to show specifications
* of file to be converted.
*-------------------------------

SHOWSPEC LDA #10
 JSR TABV
 JSR CLREOP
 JSR SENDMSG
 HEX 8D
 ASC "File name: "00
 LDX IN+$80
:PN INY
 LDA IN+$80,Y
 JSR COUT
 DEX
 BNE :PN
 JSR SENDMSG
 HEX 8D
 ASC "File type: "00
 LDA INFTYPE
 LDY #TYPEND-TYPES-1
]LUP CMP TYPES,Y  ;Check name list
 BNE :NO
 LDX #3
:PT LDA TYPES-3,Y
 JSR COUT
 INY
 DEX
 BNE :PT
 BEQ :SKP  ;Skip hex routine
:NO DEY
 DEY
 DEY
 DEY
 BPL ]LUP  ;Loop till through list
:USEH PHA   ;Not found save type
 LDA #"$"
 JSR COUT
 PLA
 JSR PRBYTE  ;Print file type
:SKP JSR SENDMSG
 HEX 8D
 ASC "Aux type:  $"00
 LDA INFAUX+1
 JSR PRBYTE
 LDA INFAUX
 JSR PRBYTE
 JSR SENDMSG
 HEX 8D
 ASC "File size: $"00
 LDA EOF+1
 JSR PRBYTE
 LDA EOF
 JSR PRBYTE
 JSR SENDMSG
 HEX 8D8D
 ASC "Ok?"00
YORN JSR SENDMSG
 ASC " (Y/N):"00
]LUP JSR RDKEY
 CMP #"["&$9F
 BEQ QUIT
 AND #%11011111
 CMP #"Y"
 BEQ PUSHOUT
 EOR #"N"
 BNE ]LUP
 LDA #"N"
PUSHOUT PHP
 JSR COUT
 PLP
 RTS   ;Returns with CS if Y

QUIT JMP EXIT

*=============================
* Input routine, headed by get
* destination EXEC file name.
*-----------------------------

GETDEST LDA #15
 JSR TABV
 JSR CLREOP
 JSR SENDMSG
 HEX 8D
 ASC "Name of EXEC file to create:"8d00
 LDX STARTUP
 BEQ INPUT0  ;Skip if no startup
:LUP INY
 LDA STARTUP,Y ;Print the startup
 ORA #$80
 CMP #"A"
 BLT :NU
 AND #%11011111
:NU STA IN-1,Y  ;And save it as if typed
 JSR COUT
 DEX
 BNE :LUP
 LDX STARTUP
INPUT0 LSR SLASHFLG
INPUT TXA
 TAY
 LDA #" "
:FAKE STA IN,Y  ;Defeat illegal picks
 INY
 CPY #$40
 BLT :FAKE
:KEY JSR RDKEY
 CMP #"U"&$9F ;But support after backspc
 BNE :NOU
 LDA IN,X  ;Pick from previous input
 ORA #$80
:NOU CMP #"."
 BEQ :OK
 CMP #$FF
 BEQ :BS
 CMP #$88
 BEQ :BS
 BIT SLASHFLG
 BPL :SLS  ;Skip if not orig filename
 LDY IN+$40
 BEQ :SLS  ; or no prefix
 CMP #"K"&$9F
 BEQ :DP
 CMP #"J"&$9F
 BNE :NOSL
 JSR INCPNT  ;Next cat entry
 LDY #0
 LDA (FPNT),Y ;Ignore if no more
 BNE :PRFILE
:DP JSR DECPNT  ;Previous cat entry
:PRFILE JSR ERASE  ;Erase current name
 JSR PRFILE  ;Print next one
 JMP :KEY
:SLS CMP #"/"
 BEQ :OK
:NOSL CMP #$8D
 BEQ :DONE
 CMP #"["&$9F ;ESC at any input returns
 BEQ :ABORT  ; to program start.
 CMP #"0"
 BLT :KEY
 CMP #"9"+1
 BLT :OK
 CMP #"A"
 BLT :KEY
 AND #%11011111
 CMP #"Z"+1
 BGE :JKEY
:OK STA IN,X
 JSR COUT
 INX
 CPX #$10
 BLT :JKEY
 BIT SLASHFLG ;Length of source file
 BMI :BS  ; at most 15
 CPX #$40  ;Other input to 63
 BLT :JKEY
:BS TXA
 BEQ :JKEY
 DEX
 JSR BACKSPC
:JKEY JMP :KEY
:DONE TXA
 RTS

:ABORT JMP START

BACKSPC JSR :BS  ;Backspace
 LDA #" "
 JSR COUT  ;Wipe previous char
:BS LDA #$88
 JMP COUT  ; & backspace again

PRFILE LDY #0
 LDA (FPNT),Y
 STA COUNT  ;Name length
 BEQ :ZERO  ;Ignore if no name
:NY INY
 LDA (FPNT),Y
 ORA #$80
 STA IN,X  ;Save as if from keybd
 JSR COUT
 INX
 DEC COUNT
 BNE :NY
:ZERO LDA #0
 STA IN,X  ;Mark for pick
 RTS

ERASE TXA   ;X holds cursor pos
 BEQ :RET
:BS JSR BACKSPC
 DEX
 BNE :BS
:RET RTS

SENDEXEC STX CH
 JSR SENDMSG
 ASC " EXEC"00
 RTS

SENDUT JSR SENDMSG
 ASC "UTIONER "00
 RTS

CLACK JSR SENDEXEC ;Print "EXEC"
 TXA
 EOR #$FF  ;Calculate # of middle
 CLC   ; spaces
 ADC #15
 ASL
 TAY
 BEQ :NOS
:SPC LDA #" "
 JSR COUT  ; and print them
 DEY
 BNE :SPC
:NOS JSR SENDUT  ; then print "UTIONER"
 LDA #$40
 JMP WAIT  ;Let him see it

*===========================
* Strings put into EXEC file
*---------------------------

CALL STR "CALL-151"

CALL2 STR "E00G"

CALL3 STR "E05G"

AD STR ",A$1000,L$"

 ERR LOADADR-$1000

F00G STR "F00G"

BSAVE STR "BSAVE "

SAVE STR "SAVE "

NEW STR "NEW"

*===============================
* Parameter tables for this pgm.
*-------------------------------

CLSPARMS DFB 1
 DFB 0

QPARMS DFB 4
 DFB 0
 DA 0
 DFB 0
 DA 0

INFPARMS DFB 10
 DA IN+$80
 DFB 0
INFTYPE DFB 0
INFAUX DA 0
 DFB 0
 DA 0
 DA 0,0
 DA 0,0

OPARMS DFB 3
OPATH DA IN+$80
 DA FILEBUF  ;File buffer
OREF DFB 0

EOFPARMS DFB 2
EOFREF DFB 0
EOF DFB 0,0,0

RWPARMS DFB 4
RWREF DFB 0
RWBUF DA PROGBUF  ;File load adrs
RWCNT DA 0
 DA 0

CREPARMS DFB 7
 DA IN+$C0
 DFB $C3
 DFB 4  ;Text
 DA 0
 DFB 1
 DA 0,0

DESPARMS DFB 1
 DA IN+$C0

PFXPARMS DFB 1
 DA IN+$40

 VAR TXTP  ;COUT

 PUT /HARD1/MERLIN/LIB/SENDMSG

*==================
* Catalog routines:
*------------------

GOERR JMP MLIERR

CAT LDA #0
 STA RWCNT
 STA RWBUF
 LDA #2  ;Read 1 block
 STA RWCNT+1
 LDA #>CATBUF
 STA RWBUF+1
 STADR IN+$40  ;OPATH
 JSR OPEN  ;Open dir of the pfx
 DOS read  ;RWPARMS
 BCS GOERR
 MOVD CATBUF+$23 ;LEN
 JSR SETPNT
 STADR FILES  ;FPNT
ACTLOOP DEC THISCNT
 BNE NXFIL
 DOS read  ;RWPARMS
 BCS :CD  ;Had eof
 JSR SETPNT
 BNE ISACT  ;Always

:CD JMP CATDONE

SETPNT LDA ENTPER  ;Get entries/block
 STA THISCNT  ; and point to start
 STADR CATBUF+4 ;PNT
 RTS

NXFIL LDA PNT  ;Point to next file
 CLC
 ADC LEN
 STA PNT
 BCC ISACT
 INC PNT+1
ISACT LDY #0
 LDA (PNT),Y
 BEQ ACTLOOP  ;Branch if file not active

* Process active file:

 AND #$F
 TAX   ;Name length
 LDY #$10
 LDA (PNT),Y
 CMP #$F
 BEQ ACTLOOP  ;Ignore directories
 LDY #0
 TXA
 STA (FPNT),Y ;Save name length
]LOOP INY
 LDA (PNT),Y  ; and file name
 ORA #$80
 STA (FPNT),Y
 DEX
 BNE ]LOOP
 JSR INCPNT  ;Bump pointer
 LDA FPNT+1
 CMP #>$BE00
 BLT ACTLOOP  ;Plenty of space

CATDONE DOS close  ;CLSPARMS
 LDY #0
 TYA
 STA (FPNT),Y ;Mark end of catalog
DECPNT LDA FPNT  ; & point to last entry
 SEC
 SBC #$10
 STA FPNT
 BCS :RET
 DEC FPNT+1
 LDA FPNT+1
 CMP #>FILES  ;If backed up too far then
 BLT INCPNT  ; go back where we were
:RET RTS

INCPNT LDA FPNT
 CLC
 ADC #$10
 STA FPNT
 BCC :RET
 INC FPNT+1
:RET RTS

*=================
* MLI error tables
*-----------------

ERRORS HEX 27,2B,40,44,45,46,47,48,49,4A,FF,00
ERREND

ERROFF DFB :IO-ERRORS
 DFB :WRTPROT-ERRORS
 DFB :INVPATH-ERRORS
 DFB :DIRNOT-ERRORS
 DFB :VOLNOT-ERRORS
 DFB :FILENOT-ERRORS
 DFB :DUP-ERRORS
 DFB :VOLFUL-ERRORS
 DFB :DIRFUL-ERRORS
 DFB :BADFORM-ERRORS
 DFB :TOOBIG-ERRORS
 DFB :BADBAS-ERRORS

:IO ASC "I/O error"00
:WRTPROT ASC "Write protected"00
:INVPATH ASC "Invalid pathname"00
:DIRNOT ASC "Directory not found"00
:VOLNOT ASC "Volume not found"00
:FILENOT ASC "File not found"00
:DUP ASC "Duplicate filename"00
:VOLFUL ASC "Volume full"00
:DIRFUL ASC "Volume directory full"00
:BADFORM ASC "Incompatible file type"00
:TOOBIG ASC "File too large"00
:BADBAS ASC "Defect in BASIC program"00

 ERR *-ERRORS/$100
 PAG
*======/A/ASM/SRC================================
* Header code written at start of file and called
* at the end of EXEC to set pfx & file info.
*------------------------------------------------

SETINF ORG $E00

 SEC
 LDA CHKSUM
 BNE :SINF
 ERR *-$E05
 CLD
 JSR CROUT
 LDA DEVNUM  ;Set current unit for
 STA :ONLUNIT ; getting the vol name
 DOS getpfx  ;:PFXP
 ORA IN+$80  ;Error or
 BNE :SINF  ; use prefix if there
 DOS online  ;:ONLP
 BCS :SINF
 LDA IN+$81  ;Else use volume name
 AND #$F
 TAX
 INX
 STX IN+$80
 LDA #'/'
 STA IN+$81
 DOS setpfx  ;:PFXP
:SINF LDX #:ERR-:ALL ;Prepare to send err msg
 BCS :MLIERR
 DOS setinfo  ;PARMS-SETINF+$E00
 BCS :MLIERR
 LDX #FILEINF-:ALL+FILENAME-NOWINF+1
 JSR :PRINT
 TAX
:MLIERR
 JSR :PRINT  ;Print "error" or
 JMP DOSWARM  ; "saved"

:OUT JSR COUT
 INX
:PRINT LDA :ALL,X
 BNE :OUT
 RTS

:ALL ASC " saved"8D00
:ERR ASC "Error"878D00

:ONLP DFB 2
:ONLUNIT DFB 0
 DA IN+$81

:PFXP DFB 1
 DA IN+$80

FILEINF ORG
NOWINF

PARMS DFB 7
 DA FILEINF+FILENAME-NOWINF
ACC DFB 0
 DFB 0
 DA 0
ZERO DFB 0
 DA 0
 DA 0,0
PARMEND

FILENAME DS $11 ;Need one 0 for stopper

SIEND ERR SIEND-SETINF/$FF

*========================================
* Decoder for 4-bit packing.  This is
* just a hex representation of the bytes.
*----------------------------------------

READSQZ ORG $F00

 CLD
 LDY #0
 STY CHKSUM
 DEY
 STY PNT
 LDA #$F
 STA PNT+1  ;Will put code at LOADADR
LOOP JSR GETLNZ  ;Read a line of file
 LDY #0
 LDX #-1
NXTBYTE JSR MAKNIB
 INCD PNT
 ASL
 ASL
 ASL
 ASL
 STA (PNT),Y  ;Store in buffer LOADADR-
 JSR MAKNIB
 ORA (PNT),Y
 STA (PNT),Y
 EOR CHKSUM
 STA CHKSUM
 BCC NXTBYTE

MAKNIB INX
 LDA IN,X
 ORA #$80
 CMP #" "
 BEQ MAKNIB  ;Skip spaces
 EOR #"0"  ;Convert ascii digit
 CMP #10  ; to hex nibble.
 BLT :GOT
 ADC #$88
 ORA #$20
 CMP #$FA
 BGE :MASK
 PLA
 PLA
 CPX #4
 BGE LOOP
 TYA
 STA (PNT),Y  ;Zero checksum
 JMP MONITOR
:MASK CLC   ;Signal digit valid
 AND #$F
:GOT RTS
 DFB 0,0  ;End of code marker
 ORG

*=============================================
* Decoder for 6-bit packed packing.  Like reg
* 6-bit packing but has special code with 1st
* byte '0' next two the repeated byte (stored
* 00000011 then 11111100) and last byte the
* count-2/2, count always is even.
*---------------------------------------------

RS6P ORG $F00

 CLD
 LDY #0
 STY CHKSUM
 STY PNT
 LDA #>LOADADR
 STA PNT+1  ;Will put code at LOADADR
:LOOP JSR GETLNZ  ;Read a line of file
 CPX #5
 BLT :MON  ;Next line till empty
 LDX #0
:NXTBYTE JSR :MAKNIB ;Get top 2 bits for
 STA TEMP  ; next 3 bytes
 LDY #-1
 ROR FLAG
:UNPACK INY
 JSR :MAKNIB  ;Get a data 6-bit nibble
 ASL TEMP  ;Shift on its top 2 bits
 ROR
 ASL TEMP
 ROR
 STA (PNT),Y
 BIT FLAG
 BMI :SKIP
 EOR CHKSUM
 STA CHKSUM
:SKIP CPY #2
 BLT :UNPACK  ;Loop till unpacked 3 bytes
 BIT FLAG
 BPL :TY
 ROL   ;Top bits clr, carry set
 STA TEMP  ;Count-1
 DEY
 LDA (PNT),Y
 ASL
 ASL   ;Clears carry
 DEY
 ORA (PNT),Y
:STR STA (PNT),Y
 INY
 DEC TEMP  ;Count down the repetition
 BPL :STR
:TY TYA
 ADC PNT  ;Bump pntr to next group
 STA PNT
 BCC :NXTBYTE
 INC PNT+1
 BCS :NXTBYTE

:NOTLEG PLA
 PLA
 BCC :LOOP :Always

:MON JMP MONITOR  ;Call monitor to do rest

:MAKNIB INX
 LDA IN,X
 ASL
 CMP #' '*2
 BEQ :MAKNIB  ;Skip over spaces
 EOR #'0'*2
 BEQ :RET
 EOR #'0'*2
 SBC #$3F*2
 BLT :NOTLEG  ;Abort if not in range
 ASL   ;Shift to top for easier
:RET RTS   ; unpacking

 DFB 0,0  ;End of code marker
 ORG

*===============================
* Regular 6-bit decoder routine:
*-------------------------------

RS6 ORG $F00

 CLD
 LDY #0
 STY CHKSUM
 STY PNT
 LDA #>LOADADR
 STA PNT+1  ;Will put code at LOADADR
:LOOP JSR GETLNZ  ;Read a line of file
 CPX #5
 BLT :MON
 LDX #0
:NXTBYTE JSR :MAKNIB ;Get top 2 bits for
 STA TEMP  ; next 3 bytes
 LDY #-1
:UNPACK INY
 JSR :MAKNIB  ;Get a data 6-bit nibble
 ASL TEMP  ;Shift on its top 2 bits
 ROR
 ASL TEMP
 ROR
 STA (PNT),Y  ;Store in buffer LOADADR-
 EOR CHKSUM
 STA CHKSUM
 CPY #2
 BLT :UNPACK  ;Loop till unpacked 3 bytes
 TYA
 ADC PNT  ;Bump pntr to next group
 STA PNT  ;Carry is set
 BCC :NXTBYTE
 INC PNT+1
 BCS :NXTBYTE

:MAKNIB INX
 LDA IN,X
 ASL
 CMP #' '*2
 BEQ :MAKNIB  ;Skip over spaces
 SBC #$3F*2
 BLT :NOTLEG  ;Abort if not in range
 ASL   ;Shift to top for easier
 RTS   ; unpacking

:NOTLEG PLA
 PLA
 BLT :LOOP  ;Next line, always taken

:MON JMP MONITOR  ;Call monitor to do rest

 DFB 0,0  ;End of code marker
 ORG

ENDPRG ERR \$3000

 DO SAVOBJ
 SAVE EXECUTIONER
 FIN