home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
enterprs
/
c128
/
text
/
examples.arc
/
CSARC.A
< prev
next >
Wrap
Text File
|
1989-12-01
|
41KB
|
1,046 lines
;csarc.asm
;=====================================================================
; MS-DOS archive create for CS-DOS (C)1988 - Ampere Metal
;=====================================================================
strend = $0033
fretop = $0035
status = $0090
fnadr = $00bb
fnlen = $00b7
fnbank = $00c7
primm = $ff7d
setlfs = $ffba
setnam = $ffbd
open = $ffc0
close = $ffc3
chkin = $ffc6
chkout = $ffc9
clrchn = $ffcc
chrin = $ffcf
chrout = $ffd2
int01 = $1701
int04 = $1704
int05 = $1705
int0a = $170a
int0c = $170c
int0d = $170d
int0e = $170e
int16 = $1716
int17 = $1717
cl = $1bf7
star = $1c01
dw star
* = star
dw there,10
db $9e
db "(7183)",0
there dw 0
lda $1bff
cmp #$13
bcs main
jsr primm
db 13,"Requires CS-DOS 1.4 or higher",13,0
lda #4
jmp int0e
main ldx #2 ;start with %2 and work up
stx parm
jsr int04 ;Make sure at least one
bcc m0 ;ok
jsr primm
db 13,"MS-DOS archive creator. (C)1988 - Ampere Metal",13
db "Version 0.01",13
db 13,"Syntax: csarc[/n] archive[.arc]"
db " pattern pattern ...",13
db 0
lda #0
jmp int0e
m0 jsr opnarc ;open output file
m1 ldx parm
jsr int16
lda cl
sta cll
bcs m3
m2 jsr arcit
jsr int17
bcc m2
m3 inc parm
ldx parm
jsr int04
bcc m1
ldx arcla
jsr chkout
lda #$1a
jsr chrout
lda #0
jsr chrout
jsr clrchn
lda #0
jmp int0e
parm db 0 ;Current parameter for int16
cll db 0 ;Save drive from int16
datala db 0 ;Save data file la
datafl db 0 ;Data filename length
stat db 0 ;Save status
bufcnt db 0 ;How many times buffer got filled. 0=only once
pass db 0 ;Pass, 0=2, $ff=1
bs dw 0 ;Temp. buffer size
;------------
; ARC a file
;------------
arcit lda cll
sta $1b01
lda #":"
sta $1b02
lda #13
jsr chrout
ldy #0
aa0 lda $1b01,y
cmp #$a0
beq aa1
jsr chrout
iny
cpy #18
bcc aa0
aa1 cpy #15
bcc aa2
jsr primm
db " <-- Can't ARC it. Name is too long",0
rts
aa2 lda #","
sta $1b01,y
iny
lda #"r"
sta $1b01,y
iny
tya
sta datafl
ldx #<$1b01
ldy #>$1b01
jsr setnam
jsr int0a
jsr setlfs
sta datala
jsr open
bcc aa3
dskerr jsr primm
db " <-- Disk Error: ",0
jsr int0c
jmp int0d
aa3 jsr lzinit
jsr inihdr
lda #1 ;1 for codesize at start
sta lzsize
lda #$ff
sta store
sta bufcnt
sta pass
sta stat
inc stat
ldx datala
jsr chkin
bcs dskerr
jsr clrchn
jsr primm
db " Analyzing,",0
aa4 jsr getbuf
bcs aa7
sec
lda bp+1
sbc strend
sta bs
lda bp+2
sbc strend+1
sta bs+1
clc
lda usql
adc bs
sta usql
lda usql+1
adc bs+1
sta usql+1
bcc aa5
inc usql+2
bne aa5
inc usql+3
aa5 inc bufcnt
jsr crnbuf
jmp aa4
aa7 lda datala
jsr close
jsr flush ;Flush crunch
mr jsr getbyt
bcc gocr
inc lzsize
bne mr
inc lzsize+1
bne mr
inc lzsize+2
bne mr
inc lzsize+3
bne mr ;Always!
gocr jsr chksiz ;Check if crunch'd size is bigger
bcs gcr ;its not, crunch
jsr primm
db "Storing,",0
lda #2
sta store
sta header+1
ldy #3
ty lda usql,y
sta lzsize,y
dey
bpl ty
jmp ggccrr
gcr jsr primm
db "Crunching,",0
lda #$ff
sta store
lda #8
sta header+1
ggccrr jsr wrthdr
jsr lzinit
inc pass
lda bufcnt ;is file entirely within the buffer?
beq mor
lda #0
sta stat
lda datafl
ldx #<$1b01
ldy #>$1b01
jsr setnam
jsr int0a
jsr setlfs
sta datala
jsr open
more jsr getbuf
bcs done
mor jsr crnbuf
jmp more
done lda datala
jsr close
bit store
bpl flshd
jsr flush ;Flush crunch
ldx arcla
jsr chkout
flsh jsr getbyt
bcc flshd
jsr chrout
jmp flsh
flshd jsr clrchn
jsr primm
db "Done.",0
rts
;-------------------
; Fill input buffer
;-------------------
getbuf bit stat
bvs gb4
bmi gb4
lda strend
sta bp+1
lda strend+1
sta bp+2
ldx datala
jsr chkin
gb0 jsr chrin ;get byte
bit pass
bpl bbp
jsr updcrc
bbp sta $ff02 ;Buffer is in bank 1
bp sta $4000 ;Store it
lda #0
sta $ff00
inc bp+1 ;Bump pointer
bne gb1
inc bp+2
gb1 lda bp+2 ;Buffer full?
cmp fretop+1
bne mbst
lda bp+1
cmp fretop
beq gb3 ;Yes, quit
mbst bit status ;EOF?
bvc gb0 ;No, get more
gb3 lda status ;Done...save status
sta stat
jsr clrchn ;And return OK
clc
rts
gb4 sec
rts
;---------------
; Crunch buffer
;---------------
crnbuf lda strend
sta pp+1
lda strend+1
sta pp+2
bit pass
bmi cb0
ldx arcla
jsr chkout
cb0 lda pp+2 ;Past end of buffer?
cmp bp+2
bne cb4 ;No, continue
lda pp+1
cmp bp+1
bne cb4
lda #0
sta $ff00
jmp clrchn ;Else done
cb4 sta $ff02 ;Fetch from bank 0
pp lda $4000
ldy #0
sty $ff00
bit store
bpl cb9
jsr crunch ;Crunch it
bcc cb1 ;No output, get next
cb2 jsr getbyt ;Else get crunched output
bcc cb1 ;No more
bit pass
bmi analyz
jsr chrout ;Send to output
jmp cb2
analyz inc lzsize
bne cb2
inc lzsize+1
bne cb2
inc lzsize+2
bne cb2
inc lzsize+3
jmp cb2
cb9 jsr chrout
cb1 inc pp+1
bne cb3
inc pp+2
cb3 jmp cb0
;--------------
; Write header
;--------------
wrthdr ldx arcla
jsr chkout
ldy #0
sty $ff00
ldx #30
bit store
bmi wh1
ldx #29
wh1 stx wh2+1
wh0 lda header,y
jsr chrout
iny
wh2 cpy #30
bcc wh0
jmp clrchn
;---------------------------------------
; Check if store is smaller than crunch
;---------------------------------------
store db 0 ;flag
chksiz lda $1bfc ;sw1
cmp #"n"
bne chksz
clc
rts
chksz sec
lda usql
sbc lzsize
lda usql+1
sbc lzsize+1
lda usql+2
sbc lzsize+2
lda usql+3
sbc lzsize+3
rts
;=========================================================================
; Misc subroutines for crunch (C)1987,1988 - Ampere Metal
;=========================================================================
; Archive entry header
header db $1a,8
fname db 0,0,0,0,0,0,0,0,0,0,0,0,0 ;Filename
lzsize db 0,0,0,0 ;Crunched size
date dw 0 ;Date
time dw 0 ;time
crc dw 0
usql dw 0,0 ;Unsqueezed length
db 12
arcla db 0
;-------------------
; Initialize header
;-------------------
inihdr clc ;Get date, use CS-DOS date
jsr $1714
stx date
sty date+1
lda $dc0b ;Stop clock, get hours
php ;save AM/PM
sed
ldx #0
and #$1f
beq ini0
ini1 inx
sbc #1
bne ini1
ini0 txa
plp
bpl ini2
cld
clc
adc #12
sed
ini2 asl a
asl a
asl a
sta time+1
ldx #0
lda $dc0a
beq ini4
ini3 inx
sbc #1
bne ini3
ini4 txa
lsr a
lsr a
lsr a
lsr a
ora time+1
sta time+1
txa
asl a
asl a
asl a
asl a
asl a
sta time
ldx #0
lda $dc09
beq ini6
ini5 inx
sbc #1
bne ini5
ini6 cld
txa
ora time
sta time
lda $dc08
lda #0 ;Finally zero CRC and lengths
sta crc
sta crc+1
ldy #3
ini7 sta usql,y
sta lzsize,y
dey
bpl ini7
iny
ini8 lda $1b03,y
cmp #","
beq ini9
jsr p2a
sta fname,y
iny
bne ini8
ini9 lda #0
sta fname,y
rts
;------------------------
; subroutine: Update CRC
;------------------------
updcrc pha ;save char
sty uc+1 ;save .y
eor crc
tay
lda crclo,y
eor crc+1
sta crc
lda crchi,y
sta crc+1
uc ldy #0
pla
rts
crclo db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $00, $c1, $81, $40, $01, $c0, $80, $41
db $01, $c0, $80, $41, $00, $c1, $81, $40
crchi db $00, $c0, $c1, $01, $c3, $03, $02, $c2
db $c6, $06, $07, $c7, $05, $c5, $c4, $04
db $cc, $0c, $0d, $cd, $0f, $cf, $ce, $0e
db $0a, $ca, $cb, $0b, $c9, $09, $08, $c8
db $d8, $18, $19, $d9, $1b, $db, $da, $1a
db $1e, $de, $df, $1f, $dd, $1d, $1c, $dc
db $14, $d4, $d5, $15, $d7, $17, $16, $d6
db $d2, $12, $13, $d3, $11, $d1, $d0, $10
db $f0, $30, $31, $f1, $33, $f3, $f2, $32
db $36, $f6, $f7, $37, $f5, $35, $34, $f4
db $3c, $fc, $fd, $3d, $ff, $3f, $3e, $fe
db $fa, $3a, $3b, $fb, $39, $f9, $f8, $38
db $28, $e8, $e9, $29, $eb, $2b, $2a, $ea
db $ee, $2e, $2f, $ef, $2d, $ed, $ec, $2c
db $e4, $24, $25, $e5, $27, $e7, $e6, $26
db $22, $e2, $e3, $23, $e1, $21, $20, $e0
db $a0, $60, $61, $a1, $63, $a3, $a2, $62
db $66, $a6, $a7, $67, $a5, $65, $64, $a4
db $6c, $ac, $ad, $6d, $af, $6f, $6e, $ae
db $aa, $6a, $6b, $ab, $69, $a9, $a8, $68
db $78, $b8, $b9, $79, $bb, $7b, $7a, $ba
db $be, $7e, $7f, $bf, $7d, $bd, $bc, $7c
db $b4, $74, $75, $b5, $77, $b7, $b6, $76
db $72, $b2, $b3, $73, $b1, $71, $70, $b0
db $50, $90, $91, $51, $93, $53, $52, $92
db $96, $56, $57, $97, $55, $95, $94, $54
db $9c, $5c, $5d, $9d, $5f, $9f, $9e, $5e
db $5a, $9a, $9b, $5b, $99, $59, $58, $98
db $88, $48, $49, $89, $4b, $8b, $8a, $4a
db $4e, $8e, $8f, $4f, $8d, $4d, $4c, $8c
db $44, $84, $85, $45, $87, $47, $46, $86
db $82, $42, $43, $83, $41, $81, $80, $40
;------------------------------------
; Subroutine: Open archive for write
;------------------------------------
dcolon db "a:"
arcnam db "--------.arc "
dotarc db ".arc"
opnarc ldx #1
jsr int04
bcc opna1
jsr primm
.asc 13,"No archive name given",13,0
lda #0
jmp int0e
opna1 ldx #0
opna2 sta arcnam,x
inx
cpx #14
bcs tolong
jsr int05
bcc opna2
stx fnlen
cpx #4
bcc addarc
ldy #3
opna3 lda dotarc,y
cmp arcnam,x
bne addarc
dex
dey
bpl opna3
bmi opnit
tolong jsr primm
db 13,"12 character maximum ARC name",13,0
lda #3
jmp int0e
addarc ldx fnlen
ldy #0
opna4 lda dotarc,y
sta arcnam,x
inx
iny
cpy #4
bcc opna4
stx fnlen
opnit lda #<arcnam
sta fnadr
lda #>arcnam
sta fnadr+1
lda #0
sta fnbank
jsr int0a
sta arcla
ldy #1
jsr setlfs
lda arcnam+1
cmp #":"
beq oagn
inc fnlen
inc fnlen
jsr int01
sta dcolon
lda #<dcolon
sta fnadr
lda #>dcolon
sta fnadr+1
oagn jsr open
bcc opna5 ;ok
jsr int0c ;get ds$
pha
jsr primm
db 13,"Error opening archive: ",0
jsr int0d
pla
jmp int0e
opna5 rts
;-----------------------------
;Convert PETSCII to true ASCII
;-----------------------------
p2a cmp #"a" ;petscii to ascii
bcc p2ax
cmp #$5b
bcs p2a2
ora #$20
rts
;
p2a2 cmp #$c1
bcc p2ax
cmp #$db
bcs p2ax
and #$7f
p2ax rts
;=========================================================================
; Lempel Zev Crunch routine for CS-DOS 12Feb88 - CS
;=========================================================================
max db 12,$10 ;Max number of bits per code and number of codes high
ext db $70 ;Extension. 4k bytes
pfx db $80 ;Prefix. 8k bytes
ncsp db $a0 ;NextCodeSamePrefix. 8k bytes
nctp db $c0 ;NextCodeThisPrefix. 8k bytes
omega dw 0 ;Current prefix
kay dw 0 ;Current extension
ncodes dw 0 ;Number of codes currently in string table
wtcl dw 0 ;Flag. When to bump code length
codsiz db 0 ;Number of bits in code
p db 0 ;Flag
check dw 0 ;Temp
save dw 0 ;Temp
temp dw 0 ;Temp
first db 0 ;Flag. First char for LZW
prev dw 0 ;Previous character for pack
count db 0 ;count for pack
outpos db 0 ;Position in 'output' for 'codout'
getpos db 0 ;Position in 'output' for 'get'
outp db 0 ;Code counter
output jsr omega ;Output buffer
bcc omega+1
jsr kay
bcc kay+1
jmp save
pla
pla
jmp check
txs
rti
sta $ff00
jmp $2e45
;----------------------------
; Initialize LZW Compression
;----------------------------
lzinit stx temp
sty temp+1
lda #0
sta outpos
sta outp
sta getpos
lda #$80
sta output
lda #0
db $2c
lzini lda #$40
sta first
lda #<257 ;First code will be 257
sta ncodes
lda #>257
sta ncodes+1
lda #9 ;9 bits per code
sta codsiz
lda #>512 ;Bump length when we reach 512 codes
sta wtcl
lda ncsp ;Clear ncsp array
jsr lzi1
lda nctp ;And nctp array
lzi1 ldx #32 ;Clear 32 pages
ldy #0
sta lzi0+2
lda $ff00
pha
lda #$ff
sta $ff01
lzi0 sta $ff00,y
iny
bne lzi0
inc lzi0+2
dex
bne lzi0
ldx temp
ldy temp+1
pla
sta $ff00
rts
;-----------------------------------------------
; Crunch a byte subroutine: Crunches byte in .a
;-----------------------------------------------
crunch bit first ;First time here?
bmi cr00 ;No
sta omega ;Yes, w=char
bvs c0r
sta prev ;prev=char
c0r lda #0
sta omega+1
sta count ;set count for pack=1
inc count
lda #$ff
sta first ;change flag
lda omega
clc ;No output
rts
cr00 sta prev+1 ;Was last char an RL control char?
lda prev
cmp #$90
bne cr03
lda #0 ;If so, send a zero
jsr cr02
lda #1
sta count
cr03 lda prev+1 ;Now handle this char
cmp #$90 ;Also a control?
beq cr06
cr05 cmp prev
beq cr01
cr06 sta prev
lda count
cmp #1
bne cpc
lda prev
jmp cr0
cr01 inc count
lda count
cmp #254
bcs cpc
lda prev
rts
cpc lda #$90 ;already sent char...now send control code
jsr cr02
lda count ;And count
jsr cr02
lda #1 ;Set new count to 1
sta count
lda prev
cr0 sta prev
cr02 sta kay ;k=char
lda $ff00
pha
sta $ff01
stx temp
sty temp+1
ldx #0 ;For (*,x)
ldy #1 ;For (*),y
jsr findwk ;Look for omega-kay in table
bcc cr1 ;Didn't find it, gotta output something
lda check ;Else w=wk
sta omega
lda check+1
sta omega+1
clc ;no output
crx ldx temp
ldy temp+1
pla
sta $ff00
lda kay ;Restore .a
rts
cr1 ldx omega ;Output omega
ldy omega+1
jsr codout
ldx #0
ldy #1
jsr addwk ;Add omega-kay to string table
lda ncodes+1 ;Table full?
cmp max+1
bcc cr3 ;no. continue
lda count ;on a run?
cmp #1
bne cr3
lda prev
cmp #$90
beq cr3
ldx kay ;yes, send k
ldy #0
jsr codout
ldx #<256 ;also RESET code
ldy #>256
jmp cr9
cr8 ldx #0
ldy #0
cr9 jsr codout
bne cr8
jsr lzini
sec
bcs crx
cr3 lda #0 ;w=k
sta omega+1
lda kay
sta omega
sec ;Flag output
bcs crx
;--------------------------------------------------
; Subroutine: Search for omega-kay in string table
;--------------------------------------------------
findwk lda omega ;check=nctp(omega)
asl a
sta save ;save=omega
sta $24
lda omega+1
rol a
sta save+1
ora nctp
sta $24+1
lda ($24,x)
sta check
lda ($24),y
sta check+1
lda #0
sta p
fwk0 lda check+1 ;if w is unextended, then return not found
bpl fwk1
clc
rts
fwk1 ora ext ;is ext(check)=k?
sta $24+1
lda check
sta $24
lda ($24,x)
cmp kay
beq fwk2 ;Yes, found wk
lda check ;Else save=check
asl a ; and check=ncsp(check)
sta save
sta $24
lda check+1
rol a
sta save+1
ora ncsp
sta $24+1
lda ($24,x)
sta check
lda ($24),y
sta check+1
sty p
jmp fwk0 ;And try again
fwk2 sec ;Found it.
rts
;-------------------------------------------
; Subroutine: Add omega-kay to string table
;-------------------------------------------
addwk lda ncodes+1 ;Table full?
cmp max+1
bcc awk0 ;No. Add it
rts
awk0 lda ncodes ;ext(ncodes)=kay
sta $24
lda ncodes+1
ora ext
sta $24+1
lda kay
sta ($24,x)
lda ncodes ;prefix(ncodes)=omega
asl a
sta $24
lda ncodes+1
rol a
ora pfx
sta $24+1
lda omega
sta ($24,x)
lda omega+1
sta ($24),y
lda p ;if p then ncsp(save)=ncodes else nctp(save)=ncodes
bne awk1
lda nctp
bne awk2
awk1 lda ncsp
awk2 sta $24+1
lda save
sta $24
lda save+1
ora $24+1
sta $24+1
lda ncodes
sta ($24,x)
lda ncodes+1
sta ($24),y
lda wtcl ;Bump codesize if nessessary
and ncodes+1
beq awk9
inc codsiz
asl wtcl
lda #0
sta outp
lda max ;But not past max codesize
cmp codsiz
bcs awk9
sta codsiz
awk9 inc ncodes ;ncodes=ncodes+1
bne awk3
inc ncodes+1
awk3 rts
;-------------------------------------------
; Subroutine: Send LZW code in xy to output
;-------------------------------------------
codout stx $24
sty $24+1
ldx outpos
ldy codsiz
cdo0 lsr $24+1
ror $24
ror output,x
bcc cdo1
inx
lda #$80
sta output,x
cdo1 dey
bne cdo0
stx outpos
inc outp
lda outp
and #7
rts
getbyt sty temp
ldy getpos
cpy outpos
bne get0
lda output,y
sta output
ldy #0
sty outpos
sty getpos
ldy temp
clc
rts
get0 lda output,y
iny
sty getpos
ldy temp
sec
rts
;-------------------------------------------------------
; Flush: all done crunching...gotta flush omega and quit
;-------------------------------------------------------
flush stx temp
sty temp+1
bit first ;Just reset table?
bmi fl00 ;No. Flush
clc
rts
fl00 lda count ;are we on a run?
cmp #1
beq fl0 ;No...just exit
lda #$90 ;Else do sequence
jsr cr02
lda count
jsr cr02
fl0 ldx omega ;flush omega
ldy omega+1
jsr codout
ldx outpos ;At byte boundary?
lda output,x
cmp #$80
beq atbb ;yes
bb lsr output,x
bcc bb
inc outpos
atbb sec ;always some output
ldx temp
ldy temp+1
rts
.end
