CP/M

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 | 45.1 KB | 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