home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
enterprs
/
c128
/
text
/
examples.arc
/
CSXARC.A
< prev
next >
Wrap
Text File
|
1989-12-01
|
46KB
|
1,695 lines
;csxarc.main
;=================================
; Extract IBM archive
;=================================
;
int01 = $1701
int04 = $1704
int05 = $1705
int08 = $1708
int0b = $170b
int0c = $170c
int0d = $170d
int0e = $170e
int15 = $1715
int16 = $1716
int17 = $1717
int21 = $1721
sw1 = $1bfc
sw2 = $1bfd
cdv = $1bf9
cl = $1bf7
maxm1 = $0039
status = $0090
fnbank = $00c7
pntr = $00ec
fnlen = $00b7
fnadr = $00bb
color = $00f1
local = $0024
primm = $ff7d
open = $ffc0
close = $ffc3
chkin = $ffc6
hexa = $b8c2
chkout = $ffc9
stop = $ffe1
clrchn = $ffcc
setlfs = $ffba
setnam = $ffbd
chrin = $ffcf
getin = $ffe4
chrout = $ffd2
ibuf = $0b00 ;input buffer
ndx = $00d0
poker = $0016
check = $00fb ;table entry to check
stkptr = $00fd ;lz stack pointer
;
* = $0c00
;
stack *=*+256 ;lz decompressor stack
code *=*+2 ;input code
oldcod *=*+2 ;previous code
finchr *=*+1
incode *=*+2 ;2 bytes
wtcl *=*+2 ;2 bytes ... when to change code length
ncodes *=*+2 ;2 bytes ... number of codes in string table
wtcl1 *=*+1 ;copy of wtcl+1
cdlen *=*+1 ;length of lzw code in bits
omega *=*+2 ;temp ... current prefix
kay *=*+1 ;temp ... current extension
arcst *=*+1 ;eof flag
count *=*+1 ;run length coding count
prev *=*+1 ;rl char for output
ltmp *=*+1
cmsk *=*+1
fnl *=*+7
ftyp *=*+1
arcla *=*+1
;
star = $1c01
.wor star
* = star
& = star
;
.wor there, 10
.byt $9e
.asc "(7183)", 0
there .wor 0
;
jsr primm
.asc 14, 13,"CSXARC for MS-DOS format archives "
.asc "(C)1987,88 - Ampere Metal",13
.asc "Compatible with SEA ARC version 5.20 or lower "
.asc "PKARC 3.5 or lower",13
.asc "Version 0.02",13, 0
;
m0 lda #0
sta ibyt
lda sw1
bne ntex
jsr int01
sta sw2
lda #"x"
sta sw1
ntex cmp #"p"
bne m3
lda sw2 ;default is /p
bne m3
lda #"p"
sta sw2
m3 lda #%00001110
sta $ff00
rol a
sta $4000
jsr opnarc
bcc m2 ;ok
jsr int0d
jmp int0e
;
m2 jsr gethdr ;get archive header
jsr res ;reset output buffer
lda #0
sta arcst
sta count
lda #<unc
sta ucr+1
lda #>unc
sta ucr+2
jsr rl0
lda method
cmp #4
bne m1
jsr usqtab
m1 jsr getnxt
bmi m4
jsr bytout
jsr stop
bne m1
jsr mbfl ;flush if e or x
jmp int0e
;
m4 lda oldcrc
cmp newcrc
bne m5
lda oldcrc+1
cmp newcrc+1
bne m5
jsr primm
.asc "...ok.",13, 0
jmp jm2
;
m5 jsr primm
.asc 14, "...CRC error!",13, 0
jm2 jsr mbfl
lda #1
jsr close
jmp m2
;
;csxarc.common
;--------------------------------
; chrout for IBM archive extract
;--------------------------------
;
bytout bit yes ;do we want this file?
bmi byto ;yep
rts
byto ldx sw1 ;option
cpx #"p" ;type?
bne bo1
jmp cvt
;
bo1 cpx #"v" ;verify
bne bo2
rts
;
bo2 cpx #"e" ;extract
bne bo3
beq bout
;
bo3 cpx #"x" ;extract
beq bout
jsr primm
.asc 13,"Bad option?", 0
jmp int0e
;
;-----------------
; buffered chrout
;-----------------
;
bout bit asctyp ;conversion?
bpl bou ;no
jsr a22p ;convert
bne bou ;not lf
rts ;ignore lf
;
bou ldx $ff00
sta $ff02
bto sta $4000
stx $ff00
inc bto+1
bne bto1
inc bto+2
bto1 lda bto+2
cmp maxm1+1
bne btox
lda bto+1
cmp maxm1
beq flush
btox rts
;
flush lda #<$4000
sta fl+1
lda #>$4000
sta fl+2
ldx #1
jsr chkout
flp ldx $ff00
sta $ff02
fl lda $4000
stx $ff00
inc fl+1
bne bfl2
inc fl+2
bfl2 jsr chrout
lda fl+1
cmp bto+1
bne flp
lda fl+2
cmp bto+2
bne flp
jsr clrchn
res lda #<$4000
sta bto+1
lda #>$4000
sta bto+2
rts
;
;-----------------------------------------
; Subroutine: flush output buffer (maybe)
;-----------------------------------------
;
mbfl lda sw1 ;is it x or e?
cmp #"x"
beq dfl
cmp #"e"
beq dfl
mbflx rts ;no. print or verify..no flush required
;
dfl lda bto+2 ;buffer empty?
cmp #>$4000
bne ddfl
lda bto+1
cmp #<$4000
beq mbflx
ddfl jmp flush
;
;csxarc.io
;-------
; bitin
;-------
;
bits .byt 1, 2, 4, 8, 16, 32, 64, 128
ibit .byt 0
ibyt .byt 0
bite .byt 0
;
bitin dec ibit ;offset into bit buffer
bpl bti1 ;need a new byte if zero
pha
jsr bytin
sta bite
lda #7
sta ibit
pla
bti1 lsr bite ;put bit in carry
rts
;
;-------
; bytin
;-------
;
srcst pla
eos pla
;
bytin sty biy+1
stx bix+1
ldy #0
sty srcst
ldy ibyt ;offset into buffer
bne bi1 ;full buffer. get char
ldx arcla ;else refresh buffer
jsr chkin
ibytlp jsr chrin
sta ibuf,y
bit status
bvs eoff
bmi eoff
iny
bne ibytlp
eoff sty eos
jsr clrchn
bi2 ldy #0
bi1 lda ibuf,y
iny
sty ibyt
beq biy
cpy eos
bne biy
dec srcst
biy ldy #0
bix ldx #0
rts
;
;--------------------------
; get archive entry header
;--------------------------
;
gethdr jsr wait ;wait for ARC header byte
sta header+1 ;save type
cmp #1 ;old type store?
bne nos ;no
lda #25 ;if so only 25 byte header
.byt $2c
nos lda #29
sta header
ldy #2 ;get 30 bytes
ghd0 jsr bytin
sta header,y
iny
cpy header
bne ghd0
lda method
cmp #1
bne ghd2
ldy #3
cpyl lda sqlen,y
sta len,y
dey
bpl cpyl
ghd2 ldy #0
ghd4 lda filenm,y
beq ghd3
jsr a22p
cmp #"A"
bcc a33p
cmp #"Z"+1
bcs a33p
and #$7f
a33p sta $1b22,y
jsr chrout
iny
bne ghd4
ghd3 sty ghd33+1
jsr chkif ;do we want this one?
lda #0 ;assume no
bcs ghd33
lda #$ff
ghd33 ldy #0
sta yes
lda #","
sta $1b22,y
iny
lda pattyp
sta $1b22,y
iny
lda #","
sta $1b22,y
iny
lda #"w"
sta $1b22,y
iny
iny
iny
tya
ldx #<$1b20
ldy #>$1b20
jsr setnam
jsr tab
lda #1
tay
jsr setlfs
lda #0
sta fnbank
lda #" "
jsr chrout
lda method
cmp #9
bne ghd9
lda #13
sta cdmax
lda #$20
sta cdmaxx
ghd9 ldx date
ldy date+1
jsr int15
lda #" "
jsr chrout
lda #0
sta ibit
sta newcrc
sta newcrc+1
lda method
cmp #8
bne ghda
jsr bytin
sta cdmax
tay
sec
lda #0
s0 rol a
bcs s0
dey
bpl s0
sta cdmaxx
lda cdmax
cmp #10
bcc ltt
clc
adc #6
ltt nop ;jsr ghexa
;jsr primm
;.asc "bit ", 0
lda cdmaxx
cmp #$40
bcc ghda
jsr primm
.asc 13,"String table too large",13, 0
jd jmp done
;
ghexa pha
jmp hex
;
ghda ldy cdmaxx
dey
sty cmxm1
lda method
jsr ptype
tay
lda mthflg,y
sta meth
lda sw1
cmp #"x"
bne ghdax
bit yes
bpl ghdax
lda sw2
bne usesw2
jsr $1701
usesw2 sta $1b20
lda #":"
sta $1b21
jsr open
jsr int0c
cmp #20
bcc ghdax
jsr int0d
jmp jd
ghdax rts
;
mthflg .byt 0, 0, 0, 0, 0
.byt 0, 0
.byt %10000000, %11000000, %11000000
;
meth .byt 9
;
;-----------------
; chrout for type
;-----------------
;
cvt pha
lda sw2
cmp #"p"
beq a2p
cmp #"a"
beq a2p
cmp #"n"
beq none
cmp #"s"
beq screen
cmp #"h"
beq hex
none pla
jmp chrout
;
screen pla
sty poker
ldx color
jsr $c003
lda #29 ; Cursor right
jsr $c00c
ldy poker
rts
;
hex lda $ff00
sta plpl+1
lda #0
sta $ff00
pla
jsr hexa
plpl lda #0
sta $ff00
rts
;
p2a pla
cmp #"a" ;petscii to ascii
bcc p2ax
cmp #$5b
bcs p2a2
ora #$20
bne p2ax
;
p2a2 cmp #$c1
bcc p2ax
cmp #$db
bcs p2ax
and #$7f
p2ax jmp chrout
;
a2p pla
jsr a22p
beq ap2x
jsr chrout
ap2x rts
;
a22p pha
lda char
sta oldchr
pla
sta char
cmp #"a" ;ascii to petscii
bcc a2px
cmp #$5b
bcs a2p2
ora #$80
bne a2px
;
a2p2 cmp #$61
bcc a2px
cmp #$7b
bcs a2px
and #$df
a2px cmp #10
bne a2pxx
lda #13
cmp oldchr
bne a2pxx
lda #10
cmp #10
a2pxx rts
;
wait jsr bytin ;wait for $1a
cmp #$1a
beq gothdr ;ok. maybe got one
bit srcst
bpl wait ;until EOF
done jsr primm
.asc 13,"Done.", 0
jmp int0e
;
gothdr jsr bytin
cmp #0
beq done
bit srcst
bmi done
cmp #$1a
beq gothdr
cmp #10
bcs help
rts
;
help jsr primm
.asc 13,"I can't handle this next file",13, 0
jmp done
;
opnarc ldx #1
jsr int04
bcc pna0
jmp int0e
;
pna0 jsr popt ;display option
ldx #1 ;setup %1 as a filename
ldy #2
jsr int21
jsr chkarc ;check for .arc extension
ldy #0
pna2 lda (fnadr),y
jsr chrout
iny
cpy fnlen
bne pna2
lda #13
jsr chrout
lda #2
sta arcla
ldy #2
jsr setlfs
jsr open
jmp int0b
;
;------------------------
; display storage method
;------------------------
;
types .asc "EOF "
.asc "Stored "
.asc "STored "
.asc "Packed "
.asc "Squeezed"
.asc "Crunched"
.asc "CRunched"
.asc "CRUnched"
.asc "CRUNched"
.asc "Squashed"
.asc "Unknown "
;
ptype pha
cmp #10
bcc pty
lda #10
pty asl a
asl a
asl a
tay
ldx #8
pt lda types,y
jsr chrout
iny
dex
bne pt
pla
rts
;
;---------
; tab(.a)
;---------
;
tab lda #" "
jsr chrout
lda pntr
cmp #21
bne tab
rts
;
;-------------------------------------
; subroutine: display selected option
;-------------------------------------
;
popt lda sw1
cmp #"e"
beq pext
cmp #"x"
beq pext
cmp #"v"
beq pver
cmp #"l"
beq plis
cmp #"p"
beq pext
jsr primm
.asc 13,"bad option",13, 0
jmp int0e
;
pext jsr primm
.asc 13,"extracting from", 0
jmp pfrom
plis jsr primm
.asc 13,"directory for", 0
jmp pfrom
pver jsr primm
.asc 13,"verifying", 0
pfrom jsr primm
.asc " archive: ", 0
rts
;
;-----------------------------------
; check filename for .arc extension
;-----------------------------------
;
dotarc .asc ".arc"
;
chkarc ldy fnlen
cpy #4
bcc adarc ;can't be there if len<4
ldx #3
dey
ckalp lda (fnadr),y
cmp dotarc,x
bne adda
dey
dex
bpl ckalp
rts
;
adda ldy fnlen
adarc ldx #0
adrc lda dotarc,x
sta (fnadr),y
iny
inx
cpx #4
bne adrc
sty fnlen
rts
;
;--------------------------------------------------------
; subroutine: check directory entry for match with pattrn
;--------------------------------------------------------
;
chknam lda #<$1b22 ;address of PETscii filename
sta $fc
lda #>$1b22
sta $fc+1
ldy #0 ;now get true filename length
ckn0 lda ($fc),y
cmp #"," ;End of name?
beq ckn1
iny
cpy #13
bcc ckn0
ckn1 sty namlen
ldy #0 ;offset into name
ldx #0 ;offset into pattern
cpx patlen ;null pattern..match nothing
beq nmatch
comnxt lda pattrn,x
cmp #"?"
beq chrmat ;found matching character
cmp #"*" ;* is sliding match
beq slide
cmp ($fc),y
beq chrmat
nmatch clc ;no match
rts
;
slide inx ;is * last char of pattern?
cpx patlen ;yes..a match
beq match
lda pattrn,x ;check for *=type
sl0 iny ;otherwise advance in name to next char of pattern
cpy namlen ;didn't find it..no match
beq nmatch
cmp ($fc),y
bne sl0
chrmat inx ;chars match...advance in both pattern and name
cpx patlen ;end of pattern?
beq eopat ;yes..match if also end of name
iny ;end of name?
cpy namlen
bne comnxt ;no..still more to check
lda pattrn,x ;end of name, but not of pattern...no match unless =typ
cmp #"*"
beq match
bne nmatch
;
eopat iny ;end of pattern
cpy namlen ;also end of name?
beq match ;yes..match
bne comnxt ;otherwise still more to check
;
match sec ;name matches
rts
;
not .byt 0
wchnam .byt 0 ;offset into directory block
namtyp .byt 0 ;file type d,s,p,u or r
namlen .byt 0 ;length of file's name in ARC header
ftypes .asc "dspur"
pattrn .asc "(C)1987,88 - Ampere Metal",0
patlen .byt 0
pattyp .byt 0 ;filetype if this is a match
asctyp .byt 0 ;ASCII type if this is a match (0=no conv, bmi=ascii)
parm .byt 0
yes .byt 0
;
;-------------------------------------------------------
; Get pattern/type for selective extraction
;-------------------------------------------------------
;
getpat stx parm
jsr gtp3 ;default type is seq
jsr int04
bcc gtp0 ;ok, continue
rts ;else none there SEC
;
gtp0 ldx #0 ;Save it
gtp1 cmp #"/" ;type?
beq gtp2 ;yes
sta pattrn,x
inx
jsr int05
bcc gtp1
stx patlen
rts
;
gtp2 jsr int05 ;get filetype
stx patlen
cmp #"p" ;prg?
bne gtp5 ;No, maybe "a"
jsr int05
bcs gtp9
gtp5 cmp #"a"
beq gtp8
lda #0 ;no conversion
.byt $2c
gtp8 lda #$ff
sta asctyp
jmp gtp9
gtp3 lda #"s" ;assume seq if not prg
gtp4 sta pattyp
gtp9 rts
;
;----------------------------------
; Check for name in parameter list
;----------------------------------
;
chkif ldx #2 ;start with %2 and work up
chif1 jsr int04
bcc chif0 ;ok its there
cpx #2 ;Not if no parameters at all
beq chkify ;Then always return true
sec
rts ;no match SEC
;
chif0 jsr getpat ;get 'pattrn', 'patlen', 'pattyp'
jsr chknam ;matches name?
bcs chkify ;yes. a match
inc parm
ldx parm
bne chif1 ;always
;
chkify clc
rts
;
;xibm.crc
;------------------------
; subroutine: Update CRC
;------------------------
;
updcrc pha ;save char
sty uc+1 ;save .y
eor newcrc
tay
lda crclo,y
eor newcrc+1
sta newcrc
lda crchi,y
sta newcrc+1
uc ldy #0
pla
rts
;
newcrc .wor 0
;
crclo .byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $00, $c1, $81, $40, $01, $c0, $80, $41
.byt $01, $c0, $80, $41, $00, $c1, $81, $40
;
crchi .byt $00, $c0, $c1, $01, $c3, $03, $02, $c2
.byt $c6, $06, $07, $c7, $05, $c5, $c4, $04
.byt $cc, $0c, $0d, $cd, $0f, $cf, $ce, $0e
.byt $0a, $ca, $cb, $0b, $c9, $09, $08, $c8
.byt $d8, $18, $19, $d9, $1b, $db, $da, $1a
.byt $1e, $de, $df, $1f, $dd, $1d, $1c, $dc
.byt $14, $d4, $d5, $15, $d7, $17, $16, $d6
.byt $d2, $12, $13, $d3, $11, $d1, $d0, $10
.byt $f0, $30, $31, $f1, $33, $f3, $f2, $32
.byt $36, $f6, $f7, $37, $f5, $35, $34, $f4
.byt $3c, $fc, $fd, $3d, $ff, $3f, $3e, $fe
.byt $fa, $3a, $3b, $fb, $39, $f9, $f8, $38
.byt $28, $e8, $e9, $29, $eb, $2b, $2a, $ea
.byt $ee, $2e, $2f, $ef, $2d, $ed, $ec, $2c
.byt $e4, $24, $25, $e5, $27, $e7, $e6, $26
.byt $22, $e2, $e3, $23, $e1, $21, $20, $e0
.byt $a0, $60, $61, $a1, $63, $a3, $a2, $62
.byt $66, $a6, $a7, $67, $a5, $65, $64, $a4
.byt $6c, $ac, $ad, $6d, $af, $6f, $6e, $ae
.byt $aa, $6a, $6b, $ab, $69, $a9, $a8, $68
.byt $78, $b8, $b9, $79, $bb, $7b, $7a, $ba
.byt $be, $7e, $7f, $bf, $7d, $bd, $bc, $7c
.byt $b4, $74, $75, $b5, $77, $b7, $b6, $76
.byt $72, $b2, $b3, $73, $b1, $71, $70, $b0
.byt $50, $90, $91, $51, $93, $53, $52, $92
.byt $96, $56, $57, $97, $55, $95, $94, $54
.byt $9c, $5c, $5d, $9d, $5f, $9f, $9e, $5e
.byt $5a, $9a, $9b, $5b, $99, $59, $58, $98
.byt $88, $48, $49, $89, $4b, $8b, $8a, $4a
.byt $4e, $8e, $8f, $4f, $8d, $4d, $4c, $8c
.byt $44, $84, $85, $45, $87, $47, $46, $86
.byt $82, $42, $43, $83, $41, $81, $80, $40
;
;csxarc.lzw
;-----------------------------
; Unsqueeze a byte subroutine
;-----------------------------
;
getnxt stx bast+1
sty basty+1
jsr dcln ;check for end of file
bit arcst
bmi bast0 ;eof...don't input past end
;
gxt ldx count ;on a run?
beq gnxt ;no
jsr rl33 ;yes - get repeated character
jmp usq89
;
gnxt ldx method ;what type of file?
cpx #4 ;just get byte if stored or packed
bcc usq88 ;yes..get byte
beq huff ;squeezed
crnch jsr ucr ;uncrunch a byte
ldx method
jmp usq80
;
huff jsr hufin
bcs eo
bcc rlo
usq88 jsr bytin
usq80 cpx #2 ;was it stored?
beq usq89 ;yes then we've got a byte
cpx #5
beq usq89
cpx #9
beq usq89
rlo jsr rlout ;otherwise it might need to be un-packed
usq89 jsr updcrc ;update crc
bast0 clc
bast ldx #0
basty ldy #0
bit arcst
rts
;
dcln ldx len ;check for end of file
bne dl0
ldx len+1
bne dl1
ldx len+2
bne dl2
ldx len+3
bne dl3
eo lda #$ff ;len is zero. flag eof
sta arcst
rts
;
dl3 dec len+3
dl2 dec len+2
dl1 dec len+1
dl0 dec len
dl4 rts
;
;----------------------------------
; run-length byte output for arc/x
;----------------------------------
;
rlout jmp rl1 ;changes
;
rl1 cmp #$90 ;is it a control character?
beq contrl ;yes-get count
sta prev
rts ;else send to output
;
contrl lda #<rl2 ;setup for count
sta rlout+1
lda #>rl2
sta rlout+2
gnx pla
pla
jmp gnxt
;
rl2 sta count
dec count
cmp #0
bne rl9
sta count
jsr rl0
lda #$90
rts
rl9 jsr rl0 ;and setup for repeat
rl33 dec count ;send char count times
bne rl44
rl0 lda #<rl1 ;reset rlout
sta rlout+1
lda #>rl1
sta rlout+2
rl44 lda prev
rl45 rts
;
;-------------------------
; lempel-zev decompressor
;-------------------------
;
ucr jmp unc ;first time in
;
unc jsr lzwrst ;reset string table
uncc jsr resstk ;reset stack
jsr codein ;get 'code'
bit meth ;old style?
bvs newsty ;no new
sta check ;else get extension for code
lda code+1
sta check+1
jsr getexc
sta kay
lda code
jmp tt
newsty sta kay ;codein returns code in .a
tt sta oldcod ;first code is a byte
lda kay
sta finchr
lda code+1 ;oldcod=code
and cmxm1
sta oldcod+1
lda #<nxtcod
sta ucr+1
lda #>nxtcod
sta ucr+2
lda kay
clc
rts
;
nxtcod jsr codein ;next code
bit meth
bvs newc
lda code+1
and #$0f
sta incode+1
ora #>used
sta poker+1
lda code
sta incode
sta poker
jsr peek
beq nxtsym
bne nsm
newc sec ;setup. test if code is defined (< ncodes)
sta incode ;incode=code
sbc ncodes
lda code+1
sta incode+1
sbc ncodes+1
bcc nxtsym ;carry clear. code was smaller.
nsm lda finchr ;undefined code - special case.
sta kay
jsr push
lda oldcod
sta code
sta omega
lda oldcod+1
sta code+1
sta omega+1
bit meth
bvs nnc
jsr hash
lda poker
sta incode
lda poker+1
and #$0f
jmp ncn
nnc lda ncodes
sta incode
lda ncodes+1
ncn sta incode+1
nxtsym bit meth
bvs nxtsy
lda code
sta poker
lda code+1
and #$0f
ora #>pfxhi
sta poker+1
jsr peek
cmp #$ff
beq kaybyt
bne nkay
nxtsy lda code+1 ;is it just a byte?
beq kaybyt ;yes-end of string
nkay lda code ;else extension(code) to stack
sta poker
lda code+1
ora #>ext
sta poker+1
jsr peek
jsr push
lda poker+1 ;and code=prefix(code)
and cmxm1
ora #>pfxlo
sta poker+1
jsr peek
sta code
lda poker+1
and cmxm1
ora #>pfxhi
sta poker+1
jsr peek
sta code+1
bit meth
bvs cnc
eor #$ff
cnc cmp #0
bne nxtsym ;until just a byte
;
kaybyt lda #<eps
sta ucr+1
lda #>eps
sta ucr+2
bit meth
bvs kbg
lda code
sta poker
lda code+1
and #$0f
ora #>ext
sta poker+1
jsr peek
jmp kbj
kbg lda code ;code is now only a single byte
kbj sta kay
sta finchr
clc
rts
;
eps jsr pull ;get from top of stack
bcs sie ;stack is empty
rts
;
sie lda oldcod
sta omega
lda oldcod+1
sta omega+1
jsr lzadd ;add omega,kay to table
lda incode ;oldcode=incode
sta oldcod
lda incode+1
sta oldcod+1
jmp nxtcod
;
;
;--------------------------------------
; subroutine. get code from input file
;--------------------------------------
;
oldcr lda #0
bne odd
sta code+1
inc oldcr+1
jsr bytin
sta code
jsr bytin
sta bytsav
ldy #4
lpcr asl a
rol code
rol code+1
dey
bne lpcr
lda code
rts
;
odd lda bytsav
and #$0f
sta code+1
jsr bytin
sta code
dec oldcr+1
rts
;
codein bit meth
bvc oldcr
lda #0
sta code
inc cdcnt ;bump code counter
ldy cdlen ;bit length of code
ci0 jsr bitin ;read in code bitwise
ror code+1
ror code
dey
bne ci0
ldy #16
ci2 lsr code+1
ror code
dey
cpy cdlen
bne ci2
ci lda code ;test eof
bne ci3 ;not 256
lda code+1
cmp #>256
bne ci3
pla
pla
jsr flb
jmp unc
;
flb lda cdcnt
and #7 ;number of codes in buffer
tay
beq gunc ;none..no flush
clc
lda #0
bbl adc cdlen ;times code len=bits in buffer
dey
bne bbl
pha ;save it
lsr a ;/8=bytes
lsr a
lsr a
tay ;save it
pla ;check for remainder
and #7
beq skpbf ;none
iny
skpbf jsr bytin
iny
cpy cdlen
bne skpbf
gunc ldy #0
sty ibit
sty cdcnt
rts
;
ci3 lda code ;and bump code length
rts
;
hm2s .byt 0, 10, 9, 7, 6, 4, 3, 1
;
;------------------------------------------
; subroutine. push/pull char to/from stack
;------------------------------------------
;
push ldy #0
sta (stkptr),y ;stkptr must be initialized
inc stkptr
bne push0
inc stkptr+1
push0 rts
;
pull lda stkptr ;check for empty stack
cmp #<stack
bne pull0
lda stkptr+1
cmp #>stack
bne pull0 ;not empty
sec ;empty
rts
;
resstk lda #<stack ;reset stack
sta stkptr
lda #>stack
sta stkptr+1
rts
;
pull0 lda stkptr
bne pull1
dec stkptr+1
pull1 dec stkptr
ldx #0
lda (stkptr,x)
clc
rts
;
;-----------------------------------
; lempel zev table reset subroutine
;-----------------------------------
;
lzwrst bit meth
bvs lzwr
lda #12
sta cdlen
sta cdmax
lda #$10
sta cdmaxx
sta cmxm1
dec cmxm1
lda #0
sta oldcr+1
sta ncodes
sta ncodes+1
inc ncodes+1
jmp init
;
lzwr lda #<257 ;set number of codes to 257
ldy #>257 ;(code 256 is reserved)
sta ncodes
sty ncodes+1
ldy #>512 ;256 of length 9 then 512 of length 10 etc.
sty wtcl
lda #9 ;code length=9
sta cdlen
lda #0 ;code counter
sta cdcnt
rts ;done
;
cdcnt .byt 0
;
;-------------------------------------------
; lempel-zev add string to table subroutine
;-------------------------------------------
;
lzadd lda ncodes+1 ;don't add if table is full
cmp cdmaxx
bcc lza1 ;its ok-add it
rts
;
lza1 sta poker+1 ;prefix(ncodes)=omega
lda ncodes
sta poker
bit meth
bvs nohash
jsr hash
nohash ldy omega+1
lda #>pfxhi
jsr poke
ldy omega
lda #>pfxlo
jsr poke
ldy kay ;extension(ncodes)=kay
lda #>ext
jsr poke
bit meth
bvs lza3
ldy #0 ;flag this code as used
lda #>used
jsr poke
lza3 inc ncodes ;and finally bump number of codes
bne lza4
inc ncodes+1
lza4 jmp bcl
;
poke sta pk1+1 ;store .y in table .a at offset in poker
lda poker+1
and cmxm1
pk1 ora #0
sta poker+1
tya
ldy #0
sta (poker),y
rts
;
;-------------------------------
; subroutines. get/put pointers
;-------------------------------
;
getexc lda check+1 ;get extension(check)
and cmxm1
ora #>ext
sta poker+1
lda check
sta poker
peek ldy #0
lda (poker),y
rts
;
bcl pha
lda cdlen ;is code 12 bits?
cmp cdmax
bcs bclrt ;if so don't adjust length
lda wtcl
and ncodes+1
beq bclrt
inc cdlen ;counted to zero. bump code length
asl wtcl ;and do twice as many next time
bclrt pla
rts
;
; initialize tables
;
init jsr inn
ldy #0
lda #>pfxhi
sta poker+1
tya
sta poker
lda #$80
init1 sta (poker),y ;set all 'used' flags to No
iny
bne init1
inc poker+1
ldx poker+1
cpx #>ext
bne init1
lda #$ff
sta omega
sta omega+1
ldx #0
init0 stx kay
jsr hash
ldy kay
lda #>ext
jsr poke
ldy #$ff
lda #>pfxlo
jsr poke
ldy #$ff
lda #>pfxhi
jsr poke
ldy #0
lda #>used
jsr poke
ldx kay
inx
bne init0
rts
;
inn lda #<next
sta poker
lda #>next
sta poker+1
ldy #0
tya
ldx #16
nxt0 sta (poker),y
iny
bne nxt0
inc poker+1
dex
bne nxt0
rts
;
;xibm.usq
;=====================
; un-squeeze routines
;=====================
;
usqtab jsr bytin ;get node count
sta ndc
jsr bytin
sta ndc+1
cmp #1
beq n256 ;256 nodes?
bcc usqt0 ;less. get table
badsq jsr primm
.asc 13,"Error...invalid decode tree.", 0
jmp done
;
ndc pla
tay
nndc pla
rts
;
n256 lda ndc
bne badsq
beq usqt0
;
usqt1 lda ndc ;must be at least one node!
ora ndc+1
beq badsq
usqt0 ldy #0 ;get tree
ldx #0
usqt3 jsr bytin
sta $4000,y ;left low
jsr bytin
sta $4100,y ;left high
jsr bytin
sta $4200,y ;right low
jsr bytin
sta $4300,y ;right high
iny
bne usqt2
inx
usqt2 cpy ndc
bne usqt3
cpx ndc+1
bne usqt3
rts
;
;--------------------
; input huffman code
;--------------------
;
hufin ldy #0
bt jsr bitin
bcc left
right lda $4300,y
bmi gr
lda $4200,y
tay
jmp bt
;
gr eor #$ff
bne eosq
lda $4200,y
eor #$ff
clc
rts
;
left lda $4100,y
bmi gl
lda $4000,y
tay
jmp bt
;
gl eor #$ff
bne eosq
lda $4000,y
eor #$ff
clc
rts
;
eosq sec
rts
;
;xibm.hash
;======================================
; hash functions for old style crunch
;=====================================
;
oldh rti ;flag old/new hash function in bit 7
;
; old hash = [(pfx+ext) OR $0800]^2 taking middle 12 bits
; new hash = [(pfx+ext) * 15073] taking lower 12 bits
;
hash lda method ;5,6=old 7=new
cmp #7
ror oldh ;bmi for new hash
clc ;start with omega+kay
lda omega
adc kay
sta n1
lda omega+1
adc #0
bit oldh ;or with $0800 if old hash
bmi hash0
ora #8
sta n1+1
sta n2+1 ;n1=n2 for old hash
lda n1
sta n2
jmp mul ;do n1*n2
;
hash0 sta n1+1 ;n2=15073 for new hash
lda #<15073
sta n2
lda #>15073
sta n2+1
mul lda #0 ;calculate n1*n2
sta poker
sta poker+1
sta poker+2
sta n1+2
sta n2+2
ldy #24
addlp lsr n2+2
ror n2+1
ror n2
bcc noadd
clc
lda n1
adc poker
sta poker
lda n1+1
adc poker+1
sta poker+1
lda n1+2
adc poker+2
sta poker+2
noadd asl n1
rol n1+1
rol n1+2
dey
bne addlp
bit oldh ;take middle bits of result for old hash
bmi agin ;take lower 12 bits if new hash
ldy #6
lpr lsr poker+2
ror poker+1
ror poker
dey
bne lpr
agin lda poker+1 ;now have hash value in poker
and #$0f ;save it and see if it's in use
sta local+1
pha
lda poker
sta local
pla
ora #>used
sta poker+1
ldy #0
lda (poker),y
bpl yoused ;it is...
rts ;its not used. return
;
;
; hash resulted in a collision
;
yoused lda local+1 ;trace it back to its root
and #$0f
ora #>next
sta local+1
ldy #0
lda (local),y
beq root
pha
lda local+1
and #$0f
ora #>neext
sta local+1
lda (local),y
sta local
pla
sta local+1
jmp yoused
;
root clc
lda local
adc #101
sta poker
lda local+1
adc #0
and #$0f
ora #>used
sta poker+1
rt1 lda (poker),y
bmi goth
inc poker
bne bmp
inc poker+1
bmp lda poker+1
cmp #>ext
bcc rt1
lda #0
sta poker
lda #>used
sta poker+1
bne rt1
;
goth lda local+1
and #$0f
ora #>next
sta local+1
lda poker+1
ldy #0
sta (local),y
lda local+1
and #$0f
ora #>neext
sta local+1
lda poker
sta (local),y
rts
;
;csxarc.dat
;====================================
; data tables for IBM un-ARC routine
;====================================
;
cdmax *=*+1
cdmaxx *=*+1
cmxm1 *=*+1
n1 *=*+3
n2 *=*+3
bytsav *=*+1
char *=*+1
oldchr *=*+1
;
header *=*+1 ;flag $1a=ok otherwise invalid
method *=*+1 ;compression method.
filenm *=*+13 ;filename. asciiz
sqlen *=*+4 ;squeezed file length
date *=*+2 ;date
time *=*+2 ;time
oldcrc *=*+2 ;stored crc
len *=*+4 ;unsqueezed file length
;
* = $4000
;
pfxlo *=*+4096
next *=*+4096
pfxhi *=*+4096
used *=*+4096
ext *=*+4096
neext *=*+4096
.end
