Original IBM HLASM assembler
Excerpt from the source of a file compression utility by Jeff Kaplan (All rights acknowledged).
* encoded data is written to stream in reversed order
* Thus code X'71' (fixed huff x41=A) 01110001 --> 10001110
* this reversed code of 10001110 is written in bit chunks as
* thus if the current writing byte is ?????011 then written as
* 01110011 and then ?????100 where the next byte will fillin ?s
LA R2,HUFFLLEN ptr fixed huffman table to be built
LA R3,X'30' value starting point
LA R4,144 loop
HUFLOOP1 STC R3,0(,R2) table
LA R2,1(,R2)
LA R3,1(,R3)
BCT R4,HUFLOOP1 ...
LA R3,X'90' value starting point
LA R4,112 loop
HUFLOOP2 STC R3,0(,R2) table
LA R2,1(,R2)
LA R3,1(,R3)
BCT R4,HUFLOOP2 ...
LA R3,X'00' value starting point
LA R4,24 loop
HUFLOOP3 STC R3,0(,R2) table
LA R2,1(,R2)
LA R3,1(,R3)
BCT R4,HUFLOOP3 ...
LA R3,X'C0' value starting point
LA R4,8 loop
HUFLOOP4 STC R3,0(,R2) table
LA R2,1(,R2)
LA R3,1(,R3)
BCT R4,HUFLOOP4 ...
LA R2,HUFFLLEN ptr fixed huffman table to be built
LA R4,288 loop
HUFFREV0 LA R3,8 bits to reverse
LA R1,128 left to right
LA RF,1 right to left
XC DWORD,DWORD use as workarea to reverse bits
HUFFREV1 EX R1,HUFFTM is bit 0 or 1
BZ HUFFREV2 zero
EX RF,HUFFOI reverse bit 1
HUFFREV2 SRL R1,1 test next bit
SLL RF,1 to set next bit
BCT R3,HUFFREV1 loop
MVC 0(1,R2),DWORD fix up with reversed byte
LA R2,1(,R2) next byte to reverse
BCT R4,HUFFREV0
OPEN (INPUT,INPUT)
*OPEN (SNAPDCB,OUTPUT)
XC SERVRETV,SERVRETV 00091007
XC SERVRETC,SERVRETC 00092007
XC SERVREAS,SERVREAS 00093007
CALL BPX1OPN,(PATHNLEN, X00094007
PATHNAME, X00095007
FILEOPTN, X00096007
FILEMODE, X00097007
SERVRETV, X00098007
SERVRETC, X00099007
SERVREAS), X00100007
VL 00110007
ICM RF,15,SERVRETV FD OR IF -1 THEN ERROR 00120007
BM FAIL 00130007
ST RF,FD SAVE FD
NEXTBLK MVC BUFFRPTR,BUFFRBGN
MVC BITCTR,=F'8' reset constant
XC BITBUCKT(16),BITBUCKT
L R2,BUFFRPTR
XC DWORD(32),DWORD clear
XC CURROFF,CURROFF
XC NEXTOFF,NEXTOFF
XC TOTALCHR,TOTALCHR
L RE,=A(BLNKDUPL) clear
LR R0,RE
SLR R1,R1
L RF,=A(258*4) len to clear
MVCL RE,R0 ...
L RE,=A(DASHDUPL) clear
LR R0,RE
SLR R1,R1
L RF,=A(258*4) len to clear
MVCL RE,R0 ...
L RE,=A(STARDUPL) clear
LR R0,RE
SLR R1,R1
L RF,=A(258*4) len to clear
MVCL RE,R0 ...
L RE,=A(EQULDUPL) clear
LR R0,RE
SLR R1,R1
L RF,=A(258*4) len to clear
MVCL RE,R0 ...
L RE,=A(ZERODUPL) clear
LR R0,RE
SLR R1,R1
L RF,=A(258*4) len to clear
MVCL RE,R0 ...
L RE,=A(HBARDUPL) clear
LR R0,RE
SLR R1,R1
L RF,=A(258*4) len to clear
MVCL RE,R0 ...
TIME DEC,DWORD,LINKAGE=SYSTEM,DATETYPE=YYYYMMDD
* pd time-hhmmssthmiju0000 date-yyyymmdd
TR DWORD(3),CNVBIN convert pd time to bin
TR DWORD+9(3),CNVBIN convert pd date to bin
SLR R0,R0
IC R0,DWORD hh
SLL R0,11
SLR R1,R1
IC R1,DWORD+1 mm
SLL R1,5
SLR RF,RF
IC RF,DWORD+2 ss
SRL RF,1 /2
OR R0,R1
OR R0,RF
STCM R0,2,FILETIME+1 INTEL reversed bytes order
STCM R0,1,FILETIME+0 ...
SLR R0,R0
IC R0,DWORD+9 yy
AL R0,=F'9' adjust year for zips
SLL R0,10
SLR R1,R1
IC R1,DWORD+10 mm
SLL R1,5
SLR RF,RF
IC RF,DWORD+11 dd
OR R0,R1
OR R0,RF
STCM R0,2,FILEDATE+1 INTEL reversed bytes order
STCM R0,1,FILEDATE+0 ...
MVC 0(L'LOCLSIGN,R2),LOCLSIGN
MVC L'LOCLSIGN(LOCLFSIZ,R2),LOCLFHDR
LA R2,L'LOCLSIGN+LOCLFSIZ(,R2)
ST R2,FILENPTR save ptr to current filename
MVC 0(5,R2),=c'block'
SLR RF,RF
ICM RF,3,CENTFCNT update total file count
CVD RF,DWORD
LA RF,1(,RF)
STCM RF,3,CENTFCNT
STCM RF,3,CENTFCN2
UNPK 5(7,R2),DWORD+4(4)
OI 11(R2),C'0'
TR 0(12,R2),X0378859
MVCIN DWORD(7),11(R2) remove leading zeroes
LA R1,1 min len of file literal
LA RF,DWORD+1
CLC ASCZEROS(6),5(R2)
BE RBLOCK0 ...
LA R1,1(,R1) incr filename len
LA RF,1(,RF) incr ptr
CLC ASCZEROS(5),5(R2)
BE RBLOCK0 ...
LA R1,1(,R1) incr filename len
LA RF,1(,RF) incr ptr
CLC ASCZEROS(4),5(R2)
BE RBLOCK0 ...
LA R1,1(,R1) incr filename len
LA RF,1(,RF) incr ptr
CLC ASCZEROS(3),5(R2)
BE RBLOCK0 ...
LA R1,1(,R1) incr filename len
LA RF,1(,RF) incr ptr
CLC ASCZEROS(2),5(R2)
BE RBLOCK0 ...
LA R1,1(,R1) incr filename len
LA RF,1(,RF) incr ptr
CLC ASCZEROS(1),5(R2)
BE RBLOCK0 ...
LA R1,1(,R1) incr filename len
LA RF,1(,RF) incr ptr
RBLOCK0 BCTR R1,0 ex len
LA RE,DWORD(R1) last valid char
EX R1,RBLOCK0M
LR RE,R2 save ptr to block???? filename for laterusage
LR RF,R2 calc ptr to filename len field
SH RF,=H'4' backtrack
LA R2,6(R1,R2) ptr
LA R1,6(,R1) total file name len
STCM R1,1,0(RF) new len
STC R1,FILENLEN central dir filenamelen
LR RF,R1 save filename len # for later usage
L R1,DIRPTR start of current saved dir info area
USING XDIRMAP,R1
MVC XFILETIM(2),FILETIME
MVC XFILEDTE(2),FILEDATE
MVC XFILENLN(2),FILENLEN
MVCIN XFILELFO(4),FILELOFF+3 save total local filehdr offset
BCTR RF,0 for ex of filename
EX RF,SAVEFN ...
B BYPASSFN continue
MOVUSSFN MVC PATHNAME(*-*),2(R2) save passed USS filename
SAVEFN MVC XFILEFNC(*-*),0(RE) copy filename from original loc
DROP R1
BYPASSFN ST R2,BUFFRPTR
ST R2,COMPRPTR save ptr to start compressed data
* setup '01'b and '1'b fixed codes; last block
LA R0,3 bit sequence='011'b
LA R1,3 bit count - rightmost 3 bits
BAL RE,BITWRITR ...