home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
mskermit.zip
/
msbpct.for
< prev
next >
Wrap
Text File
|
1988-08-16
|
15KB
|
424 lines
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