C     PROGRAM BOO2BIN
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     UNBOOING PROGRAM IN FORTRAN IV
C
C     THIS IS A UTILITY PROGRAMME TO CONVERT THE OUTPUT OF A
C     BOOING PROGRAMME STANDARD ASCII TEXT) BACK INTO BINARY DATA
C     (E.G., THE OUTPUT OF BIN2BOO.FOR)
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 KERMITS 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     BOO2BIN REVERSES THE FOLLOWING PROCESS:
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. THIS LINE IS EFFECTIVELY IGNORED BY THIS
C     PROGRAMME SINCE FORTRAN IV HAS NO WAY OF CREATING FILES; RATHER,
C     AN OUTPUT FILE MUST HAVE BEEN CREATED BEFORE AND MADE AVAILABLE
C     AS I/O UNIT 7. THE ORIGINAL NAME IS OUTPUT TO THE CONTROL CHANNEL
C     FOR DOCUMENTATION PURPOSES ONLY.
C
C     SIBLING PROGRAMMES TO ENCODE BINARY DATA 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; TEXT FILE WITH UP TO 80 CHARACTERS PER LINE
C     OUTPUT : I/O UNIT 7; 256 BYTE RECORDS. MUST HAVE BEEN CREATED EXTERNALLY.
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
C
      IMPLICIT INTEGER*4 (A-Z)
      LOGICAL ZEND
      DIMENSION NAME(12),CHUNK(4),BYTES(3)
C     NOW INITIALIZE SOME PSEUDO-CHARACTER CONSTANTS, RIGHT-JUSTIFIED
C     WITHIN EACH VARIABLE:
      DATA CREP/126/, CZERO/48/, CTILDE/126/, RBYTE/255/, CO/111/
      DATA NULL/0/
C     THE FOLLWOING CONTAINS HEX-07 = BELL AS ITS FIRST BYTE; CHANGE
C     THIS TO 1824, IF YOU'RE WORKING WITH INTEGER*2 VARIABLES:
      DATA BELL/119545888/
C --- I/O UNITS:
      DATA INPUT/5/, OUTPUT/7/, CONTRL/6/
C
C --- INITIALISATION:
      OUTCT = 0
      OUTBYT = 0
      OUTPT = 0
      NULLCT = 0
      ERRCT = 0
      ZEND = .FALSE.
      WRITE (CONTRL,10000)
10000 FORMAT (//' Conversion from boo to binary format starts.'/)
C --- READ ORIGINAL FILE NAME:
      CALL RDINI(NAME,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
      IF (ZEND) GOTO 210
      WRITE (CONTRL,11000) NAME
11000 FORMAT (' Original file name was ',12A1/)
10    CONTINUE
C --- MAIN INPUT LOOP:
      CALL RDCHAR(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
      IF (ZEND) GOTO 200
C --- GOT CHAR; IS IT NULL REPEAT CHAR?
      IF (C.NE.CREP) GOTO 30
C --- YES; GET REPEAT COUNT:
      CALL RDCHAR(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
      IF (ZEND) GOTO 100
C --- IS IT IN THE PROPER RANGE?
      IF (C.LT.CZERO .OR. C.GT.CTILDE) GOTO 25
C --- YES, OUTPUT PROPER NUMBER OF NULLS:
      IMAX = C - CZERO
      IF (IMAX.EQ.0) GOTO 90
      DO 15 I=1,IMAX
      CALL PUTBYT(NULL,OUTPUT,OUTCT,OUTBYT,OUTPT,CONTRL,ZEND)
      IF (ZEND) GOTO 140
15    CONTINUE
      NULLCT = NULLCT + IMAX
      GOTO 90
25    CONTINUE
C --- IMPROPER REPEAT COUNT:
      WRITE (CONTRL,17000) INCT,INPT,C
17000 FORMAT ('+IMPROPER NULL COUNT AT INPUT LINE',I6,', COLUMN',
     *        I4,': HEX VALUE',Z3/
     *        ' REPEAT COUNT WILL BE IGNORED.'/)
      ERRCT = ERRCT + 1
      GOTO 90
30    CONTINUE
C --- ORDINARY CHUNK:
      I = 1
      CHUNK(I) = C
C --- ASSEMBLE CHUNK:
35    CONTINUE
      IF (CHUNK(I).GE.CZERO .AND. CHUNK(I).LE.CO) GOTO 40
C --- IMPROPER CHARACTER:
      WRITE (CONTRL,17100) INCT,INPT,CHUNK(I)
17100 FORMAT ('+IMPROPER CHARACTER AT INPUT LINE',I6,', COLUMN',
     *        I4,': HEX VALUE',Z3/
     *        ' CHARACTER WILL BE IGNORED.'/)
      ERRCT = ERRCT + 1
      GOTO 45
40    CONTINUE
      CHUNK(I) = CHUNK(I) - CZERO
      I = I + 1
45    CONTINUE
C --- GET NEXT CHARACTER, IF NECESSARY:
      IF (I.GT.4) GOTO 50
      CALL RDCHAR(CHUNK(I),INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
      IF (ZEND) GOTO 120
      GOTO 35
50    CONTINUE
C --- CHUNK COMPLETE; COMBINE BITS:
      BYTES(1) = IOR(ISHFT(CHUNK(1),2),ISHFT(CHUNK(2),-4))
      BYTES(2) = IAND(IOR(ISHFT(CHUNK(2),4),ISHFT(CHUNK(3),-2)),RBYTE)
      BYTES(3) = IAND(IOR(ISHFT(CHUNK(3),6),CHUNK(4)),RBYTE)
C --- OUTPUT 3 BYTES:
      DO 55 I=1,3
      CALL PUTBYT(BYTES(I),OUTPUT,OUTCT,OUTBYT,OUTPT,CONTRL,ZEND)
      IF (ZEND) GOTO 140
55    CONTINUE
90    CONTINUE
C --- LOOP FOR NEXT CHAR:
      GOTO 10
100   CONTINUE
C --- END OF FILE WITHIN REPEAT SPEC:
      WRITE (CONTRL,17200)
17200 FORMAT (' INPUT FILE TERMINATED WITHIN NULL REPEAT.',
     *        ' SPECIFICATION.'/)
      ERRCT = ERRCT + 1
      GOTO 200
120   CONTINUE
C --- END OF FILE WITHIN CHUNK:
      WRITE (CONTRL,17300)
17300 FORMAT (' INPUT FILE TERMINATED WITHIN CHUNK.'/)
      ERRCT = ERRCT + 1
      GOTO 200
140   CONTINUE
C --- ERROR ON WRITING TO OUTPUT FILE:
      WRITE (CONTRL,17400)
17400 FORMAT (/' ERROR ON WRITING TO OUTPUT FILE.'/)
      ERRCT = ERRCT + 1
200   CONTINUE
C --- END OF FILE; FLUSH OUTPUT BUFFER BY PADDING WITH NULLS:
      CALL FLSHBO(OUTPUT,OUTCT,OUTPT,CONTRL,ZEND)
      WRITE (CONTRL,19000) NAME,INCT,INCHAR,OUTCT,OUTBYT,BLKCT,NULLCT,
     *                     ERRCT
19000 FORMAT (///' Name of originating file was: ',12A1
     *        /' Number of  input lines  :',I9,
     *         '; number of  input chars:',I9
     *        /' Number of output sectors:',I9,
     *         '; number of output bytes:',I9
     *        /' Number of blanks read   :',I9,
     *         '; number of nulls       :',I9
     *        /' Number of errors        :',I9/)
      IF (ERRCT.GT.0) WRITE (CONTRL,19100) BELL
19100 FORMAT (' OUTPUT FILE MAY BE INCORRECT.',A1/)
210   CONTINUE
      STOP
      END
C
C
      SUBROUTINE RDCHAR(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
C
C     GET A NON-BLANK CHARACTER FROM INPUT; RETURN AS C(1).
C     IF END OF FILE, RETURN ZEND = .TRUE.
C     UPDATE LINES READ (INCT), CHARS READ (INCHAR), POINTER TO INPUT LINE
C     (INPT), NUMBER OF BLANKS READ (BLKCT).
C
C     CALL RDINI FIRST FOR INITIALISATION.
C
C     WILL RETURN ORIGINAL FILE NAME IN C(1)..C(12)
C
      IMPLICIT INTEGER*4 (A-Z)
      LOGICAL ZEND
      DIMENSION C(1),INBUFF(19)
C     PSEUDO-CHARACTER BLANK:
      DATA CBLANK/32/
C
C --- MAKE SURE WE'RE NOT CALLED AFTER END OF FILE:
      C(1) = 0
C     IF (ZFOUND) GOTO 90
10    CONTINUE
      IF (INPT.GE.BUFLG) GOTO 30
C --- SIMPLY GET FROM BUFFER:
      INPT = INPT + 1
      CALL EXTRCH(C(1),INBUFF,INPT)
C --- IS C BLANK?
      IF (C(1).NE.CBLANK) GOTO 90
C --- YES, TRY AGAIN:
      BLKCT = BLKCT + 1
      GOTO 10
30    CONTINUE
C --- BUFFER EMPTY; READ NEXT LINE:
      INPT = 0
      INCT = INCT + 1
C --- REPORT PROGRESS ON CONTRL FROM TIME TO TIME:
      IF (MOD(INCT,64).EQ.0) WRITE (CONTRL,13000) INCT
13000 FORMAT ('+line',I9)
C --- ADAPT IF NECESSARY; SET BUFLG TO ACTUAL NUMBER OF CHARS READ, IF KNOWN:
      READ (INPUT,20000,END=15) INBUFF
20000 FORMAT (19A4)
      BUFLG = 76
      GOTO 10
15    CONTINUE
C --- END OF FILE; SORRY, NO MORE CHARS:
      C(1) = 0
      ZEND = .TRUE.
      GOTO 90
C
C --- ENTRY RDINI:
C
      ENTRY RDINI(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
C
      INCT = 0
      INCHAR = -1
      INPT = 0
      BLKCT = 0
      DO 55 I=1,12
55    C(I) = CBLANK
C --- ALL INITIALIZATIONS FOR READING THE INPUT FILE GO HERE:
C     ..................
C --- READ FIRST LINE, WHICH WILL CONTAIN ORIGINAL FILE NAME:
C --- ADAPT IF NECESSARY; SET BUFLG TO NUMBER OF CHARS ACTUALLY READ:
      READ (INPUT,20000,END=70) INBUFF
      BUFLG = 76
      IF (BUFLG.GT.12) BUFLG = 12
C --- WRITE NAME LEFT-JUSTIFIED INTO ARRAY C, ONE CHAR PER ELEMENT:
      DO 60 I=1,BUFLG
      CALL EXTRCH(C(I),INBUFF,I)
      C(I) = ISHFT(C(I),24)
60    CONTINUE
C --- ADAPT IF NECESSARY; SET BUFLG TO NUMBER OF CHARS ACTUALLY READ:
      READ (INPUT,20000,END=65) INBUFF
      BUFLG = 76
      GOTO 90
65    CONTINUE
      ZEND = .TRUE.
      GOTO 90
70    CONTINUE
C --- EMPTY INPUT FILE:
      ZEND = .TRUE.
      WRITE (CONTRL,17500)
17500 FORMAT (/' EMPTY INPUT FILE.'/)
90    CONTINUE
      INCHAR = INCHAR + 1
      RETURN
      END
C
C
      SUBROUTINE PUTBYT(BYTE,OUTPUT,OUTCT,OUTBYT,OUTPT,CONTRL,ZEND)
C
C     OUTPUTS ONE BYTE, UPDATES COUNT OF SECTORS (OUTCT), COUNT OF OUTPUT
C     BYTES (OUTBYT) (EVEN IF THAT'S NEARLY REDUNDANT...); AND POINTER
C     INTO OUTPUT BUFFER (OUTPT).
C     ENTRY FLSHBO MUST BE CALLED TO FINISH OFF.
C
      IMPLICIT INTEGER*4 (A-Z)
      LOGICAL ZEND
      DIMENSION SECTOR(64),UFT(5)
C     LBIT IS GOING TO BE A VARIABLE WITH ONLY THE LEFT-MOST BIT SET;
C     UNFORTUNATELY, ON MANY COMPILERS SUCH A VALUE CANNOT BE SPECIFIED
C     WITHOUT SUBTERFUGE. HENCE, WE INITIALIZE RBIT TO 1 AND LATER SET
C     LBIT TO RBIT, SHIFTED LEFT BY 31 POSITIONS. (IF YOU USE INTEGER*2
C     VARIABLES, YOU WILL WANT TO CHANGE THAT TO 15 POSITIONS.)
C     IF YOUR MACHINE DOESN'T USE TWO'S COMPLEMENT, YOU HAVE TO START
C     THINKING YOURSELF:
      DATA RBIT/1/
      DATA NULL/0/
C --- SECLEN IS NUMBER OF BYTES IN A TYPICAL, FIXED-LENGTH BINARY RECORD:
C     IT CORRESPONDS TO LENGTH OF ARRAY SECTOR MEASURED IN BYTES;
C     OPTION IS NEEDED FOR MODCOMP ONLY:
      DATA SECLEN/256/, OPTION/36864/
C
C --- NOW SET LBIT TO WHAT IT ALWAYS SHOULD HAVE BEEN:
      LBIT = ISHFT(RBIT,31)
      IF (OUTPT.LT.SECLEN) GOTO 20
C --- OUTPUT BUFFER IS FULL; WRITE A BINARY RECORD:
      IF (OUTCT.NE.0) GOTO 10
C --- ON FIRST CALL, INITIALIZE OUTPUT FILE FOR WRITING BINARY RECORDS;
C     WRITING MUST BE UNDISTURBED BY ANY CONTROL CHARACTERS.
C --- ON MODCOMP, THAT MEANS INITIALIZING A UFT; REPLACE WITH WHATEVER
C     YOU NEED:
      CALL BLDUFT(UFT,0,ICAN4(OUTPUT),OPTION)
10    CONTINUE
C --- DO A BINARY WRITE OF SECLEN BYTES = ONE RECORD:
C     AGAIN, REPLACE WITH WHATEVER YOU NEED. MAYBE A PLAIN WRITE WITH
C     FORMAT (64A4) WILL DO FOR YOU.
      CALL WRITE4(UFT,SECTOR,SECLEN)
C --- CHECK FOR ERROR CONDITION; ADAPT OR OMIT:
      IF (IAND(UFT(1),LBIT).NE.0) GOTO 80
      OUTCT = OUTCT + 1
      OUTPT = 0
20    CONTINUE
C --- MOVE BYTE TO OUTPUT BUFFER:
      OUTBYT = OUTBYT + 1
      OUTPT = OUTPT + 1
      CALL INSRCH(BYTE,SECTOR,OUTPT)
      GOTO 90
C
C --- ENTRY FLSHBO:
C
      ENTRY FLSHBO(OUTPUT,OUTCT,OUTPT,CONTRL,ZEND)
C
      IF (OUTCT.NE.0) GOTO 25
C --- JUST TO MAKE SURE, IF THE FILE WAS VERY SHORT:
C --- ANOTHER COPY OF THE INITIALIZATION STATEMENTS; CF. ABOVE:
      CALL BLDUFT(UFT,0,ICAN4(OUTPUT),OPTION)
25    CONTINUE
      IF (OUTPT.EQ.SECLEN) GOTO 40
C --- PAD WITH NULLS:
      IMAX = SECLEN - OUTPT
      DO 30 I=1,IMAX
      CALL INSRCH(NULL,SECTOR,OUTPT+I)
30    CONTINUE
      OUTPT = SECLEN
40    CONTINUE
C --- BINARY WRITE OF SECLEN BYTES = ONE RECORD; ADAPT IF NECESSARY
C     (CF. ABOVE).
      CALL WRITE4(UFT,SECTOR,SECLEN)
C --- CHECK FOR ERROR CONDITION; ADAPT OR OMIT:
      IF (IAND(UFT(1),LBIT).NE.0) GOTO 80
      OUTCT = OUTCT + 1
      OUTPT = 0
C --- CLOSE OUTPUT FILE IN AN ORDERLY FASHION:
      ENDFILE OUTPUT
      GOTO 90
80    CONTINUE
      WRITE (CONTRL,13700)
13700 FORMAT (/' ERROR ON WRITING TO OUTPUT FILE.'/)
      ZEND = .TRUE.
90    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
      IMPLICIT INTEGER*4 (A-Z)
      DIMENSION BUFFER(1)
C     THE LAST 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
      IMPLICIT INTEGER*4 (A-Z)
      DIMENSION BUFFER(1)
C     A VARIABLE WITH EACH AND EVERY BIT SET; IF YOUR MACHINE DOESN'T USE
C     TWO'S COMPLEMENT, YOU GOT TO DO SOME MORE THINKING:
      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
