C     PROGRAM BIN2BOO
C
C****** GISBERT W.SELKE (RECK@DBNUAMA1.BITNET), 05/11/87
C     WISSENSCHAFTLICHES INSTITUT DER ORTSKRANKENKASSEN,
C     KORTRIJKER STRASSE 1, D-5300 BONN 2, WEST GERMANY
C     RECK@DBNUAMA1.BITNET
C
C     BOOING PROGRAM IN FORTRAN IV
C
C     THIS IS A UTILITY PROGRAMME TO CONVERT BINARY DATA INTO
C     STANDARD ASCII TEXT IN ORDER TO FACILITATE DATA TRANSFER
C
C     IT IS NOT MEANT TO BE A TRANSFER PROTOCOL REPLACEMENT; IT
C     JUST MAKES TRANSFER POSSIBLE ACROSS LINES (E.G., DATA NETWORKS)
C     WHEN NO KERMIT ARE AVAILABLE OR ONE OF THEM CAN'T COPE WITH
C     BINARY STUFF.
C
C     BEWARE OF GREMLINS, THOUGH; ESPECIALLY EBCDIC <-> ASCII
C     TRANSLATION MAY BE A PROBLEM FOR SOME OF THE CHARACTERS ...
C
C     BASICALLY, 3 BYTES = 24 BITS ARE ENCODED INTO 4 CHARACTERS
C     BY DIVIDING THEM INTO 6-BIT-PIECES AND THEN ADDING ASCII-ZERO
C     TO MAKE THESE PIECES PRINTABLE. THE RESULT LIES IN THE RANGE
C     ASCII-ZERO TO ASCII-SMALL-O. - IN ADDITION, NULL COMPRESSION
C     TAKES PLACE; CONSECUTIVE NULL BYTES (WHICH OCCUR FREQUENTLY
C     IN EXECUTABLE FILES, E.G.) ARE ENCODED WITH A TILDE LEAD-IN
C     FOLLOWED BY THE NUMBER OF NULLS (UP TO 78), AGAIN RENDERED
C     PRINTABLE BY ADDING ASCII-ZERO. THE RESULTING CHARACTER IS IN
C     THE RANGE ASCII-ZERO (WELL, ASCII-TWO OR -THREE, REALLY) TO
C     TILDE (ASCII CODE 126). - CHUNKS OF FOUR CHARACTERS BELONGING
C     TOGETHER (RSP. TILDE AND NULL REPEAT COUNT) SHOULD NOT BE
C     DIVIDED ACROSS LINES. A LINE HAS A MAXIMUM LENGTH OF 76
C     CHARACTERS. - IN ADDITION, THE FIRST LINE OF THE FILE CONTAINS
C     THE NAME OF THE ORIGINAL FILE (IF KNOWN - OTHERWISE A DUMMY NAME)
C     AND NOTHING ELSE.
C
C     SIBLING PROGRAMMES TO DECODE BOO FORMAT EXIST IN A VARIETY OF
C     LANGUAGES, MOST NOTABLY C, PASCAL, BASIC, AND FORTRAN, OF COURSE.
C
C     THE BOO-FORMAT WAS DEVELOPPED FOR SAFE (WELL, NOT *REALLY* SAFE...)
C     BOOTSTRAPPING PURPOSES DURING KERMIT EVOLUTION BY BILL CATCHINGS
C     AND FRANK DA CRUZ OF COLUMBIA UNIVERSITY, OR SO I THINK.
C
C     THANKS TO FRANK, BILL, DAPHNE AND MANY OTHER PEOPLE FOR ALL
C     THEY'VE DONE TO MAKE LIFE EASIER!
C
C     CERTAIN SYSTEM SPECIFIC FEATURES CANNOT BE AVOIDED; HENCE,
C     YOU SHOULD CHECK THE CODE BELOW CAREFULLY. I HAVE TRIED TO
C     INDICATE THE PLACES WHERE PROBLEMS ARE LIKELY TO OCCUR;
C     THESE INCLUDE WORD-SIZE DEPENDANCIES AND THE WAY BINARY
C     I/O (I.E., UNHAMPERED BY ANY CONTROL CHARACTERS) IS
C     ACCOMPLISHED. ALSO, THE INPUT RECORD SIZE WILL NEED CHECKING.
C
C     AS FAR AS POSSIBLE, PARAMETERS ARE SET IN DATA STATEMENTS IN
C     THE SUBROUTINES TO WHICH THEY PERTAIN; I/O CHANNEL NUMBERS
C     ARE ASSIGNED IN A DATA STATEMENT IN THE MAIN PROGRAMME (BELOW).
C
C     IMPROVEMENTS ARE WELCOME AND SHOULD BE SENT EITHER DIRECTLY
C     TO THE AUTHOR OR TO THE KERMIT MAINTAINERS AT COLUMBIA UNIVERSITY,
C     NEW YORK, USA.
C
C     PARAMETERS ARE SET AS FOLLOWS:
C     INPUT  : I/O UNIT 5; ASSUMED TO BE 256 BYTE RECORDS
C     OUTPUT : I/O UNIT 7; PADDED WITH BLANKS TO YIELD 80 CHARACTERS ALWAYS
C     CONTROL OUTPUT: I/O UNIT 6 (NOT REALLY NECESSARY)
C
C     NO REWIND WILL BE PERFORMED ON EITHER INPUT OR OUTPUT BEFORE OR
C     AFTER PROCESSING. OUTPUT FILE WILL HAVE A SINGLE FILE MARK AT END.
C
C     ALL VARIABLES ARE ASSUMED TO BE 32-BIT-QUANTITIES
C
      IMPLICIT INTEGER*4 (A-Z)
      LOGICAL*4 ZFOUND,ZNULL
      REAL*4 RATE
      DIMENSION CHUNK(4),BYTES(3)
C     INITIALIZATION OF SOME PSEUDO-CHARACTER CONSTANTS, EACH RIGHT-
C     JUSTIFIED IN AN INTEGER VARIABLE:
C     R6BITS HAS THE 6 RIGHT-MOST BITS SET; CZERO IS ASCII-0, AND
C     CREP IS ASCII-TILDE:
      DATA R6BITS/63/, CZERO/48/, CREP/126/
      DATA LMAX/78/, NULL/0/, TWO/2/, FOUR/4/
C --- I/O UNITS:
      DATA INPUT/5/, OUTPUT/7/, CONTRL/6/
C
C --- INITIALISATION:
      INCT = 0
      INBYTE = 0
      INPT = 0
      NULLCT = 0
      ZFOUND = .TRUE.
      WRITE (CONTRL,10000)
10000 FORMAT (//' Conversion from binary to boo format starts.'/)
      CALL WRINI(OUTPUT,OUTCT,OUTCHR,OUTPT)
10    CONTINUE
C --- MAIN INPUT LOOP:
C --- ASSEMBLE 3 BYTES:
      CALL GETBYT(BYTES(1),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
      IF (.NOT.ZFOUND) GOTO 200
12    ZNULL = BYTES(1).EQ.NULL
      CALL GETBYT(BYTES(2),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
      ZNULL = ZNULL .AND. BYTES(2).EQ.NULL
      CALL GETBYT(BYTES(3),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
      ZNULL = ZNULL .AND. BYTES(3).EQ.NULL
15    CONTINUE
      IF (.NOT.ZNULL) GOTO 30
C --- START NULL COMPRESSION:
      I = 3
20    CONTINUE
      I = I + 1
      CALL GETBYT(BYTES(1),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
      IF ((BYTES(1).EQ.NULL) .AND. ZFOUND .AND. (I.LE.LMAX)) GOTO 20
C --- END OF NULL SEQUENCE:
      I = I - 1
      NULLCT = NULLCT + I
      CHUNK(1) = CREP
      CHUNK(2) = I + CZERO
      CALL WRCHAR(CHUNK,OUTPUT,OUTCT,OUTCHR,OUTPT,TWO)
      IF (ZFOUND) GOTO 12
      GOTO 200
30    CONTINUE
C --- NON-NULL BYTES; SHIFT BITS TO FORM CHUNK:
      CHUNK(1) = ISHFT(BYTES(1),-2) + CZERO
      CHUNK(2) = IAND(IOR(ISHFT(BYTES(1),4),ISHFT(BYTES(2),-4)),
     *                R6BITS) + CZERO
      CHUNK(3) = IAND(IOR(ISHFT(BYTES(2),2),ISHFT(BYTES(3),-6)),
     *                R6BITS) + CZERO
      CHUNK(4) = IAND(BYTES(3),R6BITS) + CZERO
      CALL WRCHAR(CHUNK,OUTPUT,OUTCT,OUTCHR,OUTPT,FOUR)
      IF (ZFOUND) GOTO 10
200   CONTINUE
C --- END OF FILE; FLUSH OUTPUT BUFFER BY PADDING WITH BLANKS:
      CALL FLSHSO(OUTPUT,OUTCT,OUTPT)
      RATE = 0.0
      IF (OUTCHR.GT.0) RATE = (100.0*INBYTE) / OUTCHR
      WRITE (CONTRL,19000) INCT,INBYTE,OUTCT,OUTCHR,NULLCT,RATE
19000  FORMAT (//' Number of  input sectors:',I9,
     *         '; number of  input bytes:',I9
     *        /' Number of output lines  :',I9,
     *         '; number of output chars:',I9
     *        /' Number of nulls         :',I9,
     *         '; efficiency             :',F8.1,'%'/)
      STOP
      END
C
C
      SUBROUTINE WRCHAR(CHUNK,OUTPUT,OUTCT,OUTCHR,OUTPT,NBR)
C
C     OUTPUT NBR CHARACTERS (CHUNK) TO OUTPUT;
C     UPDATE LINES WRITTEN (OUTCT), CHARS WRITTEN (OUTCHR),
C     POINTER TO OUTPUT LINE (OUTPT)
C
C     CALL WRINI FIRST FOR INITIALISATION.
C     CALL FLSHSO FOR FINISHING OFF.
C
      IMPLICIT INTEGER*4 (A-Z)
      DIMENSION CHUNK(1),OUTLIN(20),DUMNAM(3)
C     MAXLGT IS MAXIMUM NUMBER OF CHARACTERS ALLOWED; LINLEN IS
C     NUMBER OF 32-BIT-WORDS ACTUALLY WRITTEN (DIMENSION OF OUTLIN):
      DATA MAXLGT/76/, LINLEN/20/
C     CBLANK IS ASCII-BLANK, RIGHT-JUSTIFIED, BLANK4 IS 4 BYTES BLANK:
      DATA CBLANK/32/, BLANK4/'    '/
C --- SOME FORTRANS HAVE NO WAY OF KNOWING EXTERNAL FILES NAMES,
C     HENCE SUPPLY DUMMY NAME:
      DATA DUMNAM/'BINA','RY.D','AT  '/
C
C --- IS BUFFER FULL?
      IF (OUTPT+NBR.LE.MAXLGT) GOTO 10
C --- BUFFER IS INDEED FULL; PAD TO BUFFER LENGTH AND PUT IT OUT:
      K = 4*LINLEN - 1
      DO 5 I=OUTPT,K
5     CALL INSRCH(CBLANK,OUTLIN,I+1)
      WRITE (OUTPUT,40000) OUTLIN
C --- ADAPT IF NECESSARY:
40000 FORMAT (20A4)
      OUTCT = OUTCT + 1
      OUTPT = 0
10    CONTINUE
C --- PUT IN CHARACTERS:
      DO 20 I=1,NBR
      OUTPT = OUTPT + 1
      OUTCHR = OUTCHR + 1
      CALL INSRCH(CHUNK(I),OUTLIN,OUTPT)
20    CONTINUE
      GOTO 90
C
C     ENTRY WRINI:
C
      ENTRY WRINI(OUTPUT,OUTCT,OUTCHR,OUTPT)
C
C --- ALL INITIALIZATIONS NEEDED FOR THE OUTPUT FILE GO HERE:
C --- WRITE DUMMY FILE NAME TO OUTPUT FILE, SINCE WE DON'T KNOW BETTER:
      DO 30 I=1,3
30    OUTLIN(I) = DUMNAM(I)
      K = 4*LINLEN
      DO 35 I=13,K
35    CALL INSRCH(CBLANK,OUTLIN,I)
      WRITE (OUTPUT,40000) OUTLIN
      OUTCT = 0
      OUTCHR = 0
      OUTPT = 0
      GOTO 90
C
C --- ENTRY FLSHSO:
C
      ENTRY FLSHSO(OUTPUT,OUTCT,OUTPT)
C
C --- ANYTHING TO CLOSE THE OUTPUT FILE GOES HERE:
      K = 4*LINLEN - 1
      DO 50 I=OUTPT,K
50    CALL INSRCH(CBLANK,OUTLIN,I+1)
C --- WRITE THE REST:
      WRITE (OUTPUT,40000) OUTLIN
      OUTCT = OUTCT + 1
C --- ANYTHING TO CLOSE THE OUTPUT FILE:
      ENDFILE OUTPUT
90    CONTINUE
      RETURN
      END
C
C
      SUBROUTINE GETBYT(BYTE,INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
C
C     GET ONE BYTE FROM INPUT; UPDATE COUNT OF SECTORS (INCT),
C     COUNT OF INPUT BYTES(INBYTE) (EVEN IF THAT'S NEARLY REDUNDANT...)
C     AND POINTER INTO INPUT BUFFER (INPT).
C     ZFOUND IS TRUE IFF BYTE WAS FOUND.
C     REPORT PROGRESS ON UNIT CONTRL.
C
      IMPLICIT INTEGER*4 (A-Z)
      LOGICAL*4 ZFOUND
C --- UFT IS NEEDED FOR MODCOMP BINARY READ:
      DIMENSION SECTOR(64),UFT(5)
C     THESE VARIABLES ARE FOR MODCOMP USE ONLY:
      DATA OPTION/36864/, EOFBIT/2097152/
C --- SECLEN IS NUMBER OF BYTES IN A TYPICAL, FIXED-LENGTH BINARY RECORD:
      DATA SECLEN/256/
C
      BYTE = 0
      IF (.NOT.ZFOUND) GOTO 95
C --- CHECK IF FIRST CALL:
      IF (INCT.NE.0) GOTO 10
C --- YES; ANYTHING TO INITIALIZE INPUT FILE FOR READING GOES HERE;
C     READING MUST BE UNDISTURBED BY ANY CONTROL CHARACTERS:
C --- INITIALIZE UFT FOR READING (MODCOMP; REPLACE WITH WHATEVER YOU
C     NEED):
C
      CALL BLDUFT(UFT,0,ICAN4(INPUT),OPTION)
C
      GOTO 12
10    CONTINUE
C --- IS SOMETHING LEFT IN THE BUFFER?
      IF (INPT.LT.SECLEN) GOTO 20
C --- NO; GET NEXT SECTOR:
12    INCT = INCT + 1
C --- DO A BINARY READ OF SECLEN BYTES = ONE RECORD:
C     (AGAIN, REPLACE WITH WHATEVER YOU NEED, MAYBE A PLAIN READ WITH
C     FORMAT (64A4) WILL DO FOR YOU. REMEMBER TO CHECK FOR END OF FILE.)
C
      CALL READ4(UFT,SECTOR,SECLEN)
C
C --- END OF FILE??
      IF (IAND(UFT(1),EOFBIT).NE.0) GOTO 90
C --- NO; NEXT SECTOR FOUND:
C --- REPORT PROGRESS ON CONTROL UNIT FROM TIME TO TIME:
      IF (MOD(INCT,64).EQ.0) WRITE (CONTRL,17000) INCT
17000 FORMAT ('+Record',I9)
      INPT = 0
20    CONTINUE
C --- GET NEXT BYTE FROM BUFFER:
      INPT = INPT + 1
      INBYTE = INBYTE + 1
      CALL EXTRCH(BYTE,SECTOR,INPT)
      GOTO 95
90    CONTINUE
      ZFOUND = .FALSE.
95    CONTINUE
      RETURN
      END
C
C
      SUBROUTINE EXTRCH(C,BUFFER,POS)
C
C     GET POS-TH BYTE FROM BUFFER, RETURN IT RIGHT-JUSTIFIED WITHIN C:
C     BUFFER IS REGARDED AS TIGHTLY PACKED 32-BIT-QUANTITIES-ARRAY
C
      IMPLICIT INTEGER*4 (A-Z)
      DIMENSION BUFFER(1)
C     THESE ARE THE RIGHT-MOST 8 BITS:
      DATA RBYTE/255/
C
      I = (POS+3) / 4
      K = POS - 4*(I-1)
      C = BUFFER(I)
C --- NOW SHIFT; BUT FOR THE BENEFIT OF SOME FAULTY COMPILERS,
C     DONT'T IF SHIFT COUNT IS 0:
      IF (K.NE.4) C = ISHFT(C,8*K-32)
      C = IAND(C,RBYTE)
      RETURN
      END
C
C
      SUBROUTINE INSRCH(C,BUFFER,POS)
C
C     INSERT RIGHT-MOST BYTE OF C INTO POS-TH BYTE OF BUFFER.
C     ASSUME C IS 0 IN 3 FIRST BYTES AND THERE ARE NO SIGNIFICANT BYTES
C     AFTER POS IN BUFFER
C     BUFFER IS REGARDED AS TIGHTLY PACKED 32-BIT-QUANTITIES-ARRAY
C
      IMPLICIT INTEGER*4 (A-Z)
      DIMENSION BUFFER(1)
C     THIS IS A VARIABLE WITH EACH AND EVERY BIT SET; IF YOUR MACHINE
C     DOESN'T USE TWO'S COMPLEMENT, YOU GOT TO FIGURE OUT HOW TO DO IT:
      DATA FULLBT/-1/
C
      I = (POS+3)/4
      K = POS - 4*(I-1)
      CA = C
C --- NOW SHIFT; BUT FOR THE BENEFIT OF SOME FORTRAN COMPILERS,
C     DON'T IF SHIFT COUNT IS ZERO:
      IF (K.NE.4) CA = ISHFT(CA,32-8*K)
      MASK = ISHFT(FULLBT,40-8*K)
      BUFFER(I) = IOR(IAND(BUFFER(I),MASK),CA)
      RETURN
      END
