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 ...