CP/M

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