home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / mskermit / msbmkb.for < prev    next >
Text File  |  2020-01-01  |  11KB  |  325 lines
  1. C     PROGRAM BIN2BOO
  2. C
  3. C****** GISBERT W.SELKE (RECK@DBNUAMA1.BITNET), 05/11/87
  4. C     WISSENSCHAFTLICHES INSTITUT DER ORTSKRANKENKASSEN,
  5. C     KORTRIJKER STRASSE 1, D-5300 BONN 2, WEST GERMANY
  6. C     RECK@DBNUAMA1.BITNET
  7. C
  8. C     BOOING PROGRAM IN FORTRAN IV
  9. C
  10. C     THIS IS A UTILITY PROGRAMME TO CONVERT BINARY DATA INTO
  11. C     STANDARD ASCII TEXT IN ORDER TO FACILITATE DATA TRANSFER
  12. C
  13. C     IT IS NOT MEANT TO BE A TRANSFER PROTOCOL REPLACEMENT; IT
  14. C     JUST MAKES TRANSFER POSSIBLE ACROSS LINES (E.G., DATA NETWORKS)
  15. C     WHEN NO KERMIT ARE AVAILABLE OR ONE OF THEM CAN'T COPE WITH
  16. C     BINARY STUFF.
  17. C
  18. C     BEWARE OF GREMLINS, THOUGH; ESPECIALLY EBCDIC <-> ASCII
  19. C     TRANSLATION MAY BE A PROBLEM FOR SOME OF THE CHARACTERS ...
  20. C
  21. C     BASICALLY, 3 BYTES = 24 BITS ARE ENCODED INTO 4 CHARACTERS
  22. C     BY DIVIDING THEM INTO 6-BIT-PIECES AND THEN ADDING ASCII-ZERO
  23. C     TO MAKE THESE PIECES PRINTABLE. THE RESULT LIES IN THE RANGE
  24. C     ASCII-ZERO TO ASCII-SMALL-O. - IN ADDITION, NULL COMPRESSION
  25. C     TAKES PLACE; CONSECUTIVE NULL BYTES (WHICH OCCUR FREQUENTLY
  26. C     IN EXECUTABLE FILES, E.G.) ARE ENCODED WITH A TILDE LEAD-IN
  27. C     FOLLOWED BY THE NUMBER OF NULLS (UP TO 78), AGAIN RENDERED
  28. C     PRINTABLE BY ADDING ASCII-ZERO. THE RESULTING CHARACTER IS IN
  29. C     THE RANGE ASCII-ZERO (WELL, ASCII-TWO OR -THREE, REALLY) TO
  30. C     TILDE (ASCII CODE 126). - CHUNKS OF FOUR CHARACTERS BELONGING
  31. C     TOGETHER (RSP. TILDE AND NULL REPEAT COUNT) SHOULD NOT BE
  32. C     DIVIDED ACROSS LINES. A LINE HAS A MAXIMUM LENGTH OF 76
  33. C     CHARACTERS. - IN ADDITION, THE FIRST LINE OF THE FILE CONTAINS
  34. C     THE NAME OF THE ORIGINAL FILE (IF KNOWN - OTHERWISE A DUMMY NAME)
  35. C     AND NOTHING ELSE.
  36. C
  37. C     SIBLING PROGRAMMES TO DECODE BOO FORMAT EXIST IN A VARIETY OF
  38. C     LANGUAGES, MOST NOTABLY C, PASCAL, BASIC, AND FORTRAN, OF COURSE.
  39. C
  40. C     THE BOO-FORMAT WAS DEVELOPPED FOR SAFE (WELL, NOT *REALLY* SAFE...)
  41. C     BOOTSTRAPPING PURPOSES DURING KERMIT EVOLUTION BY BILL CATCHINGS
  42. C     AND FRANK DA CRUZ OF COLUMBIA UNIVERSITY, OR SO I THINK.
  43. C
  44. C     THANKS TO FRANK, BILL, DAPHNE AND MANY OTHER PEOPLE FOR ALL
  45. C     THEY'VE DONE TO MAKE LIFE EASIER!
  46. C
  47. C     CERTAIN SYSTEM SPECIFIC FEATURES CANNOT BE AVOIDED; HENCE,
  48. C     YOU SHOULD CHECK THE CODE BELOW CAREFULLY. I HAVE TRIED TO
  49. C     INDICATE THE PLACES WHERE PROBLEMS ARE LIKELY TO OCCUR;
  50. C     THESE INCLUDE WORD-SIZE DEPENDANCIES AND THE WAY BINARY
  51. C     I/O (I.E., UNHAMPERED BY ANY CONTROL CHARACTERS) IS
  52. C     ACCOMPLISHED. ALSO, THE INPUT RECORD SIZE WILL NEED CHECKING.
  53. C
  54. C     AS FAR AS POSSIBLE, PARAMETERS ARE SET IN DATA STATEMENTS IN
  55. C     THE SUBROUTINES TO WHICH THEY PERTAIN; I/O CHANNEL NUMBERS
  56. C     ARE ASSIGNED IN A DATA STATEMENT IN THE MAIN PROGRAMME (BELOW).
  57. C
  58. C     IMPROVEMENTS ARE WELCOME AND SHOULD BE SENT EITHER DIRECTLY
  59. C     TO THE AUTHOR OR TO THE KERMIT MAINTAINERS AT COLUMBIA UNIVERSITY,
  60. C     NEW YORK, USA.
  61. C
  62. C     PARAMETERS ARE SET AS FOLLOWS:
  63. C     INPUT  : I/O UNIT 5; ASSUMED TO BE 256 BYTE RECORDS
  64. C     OUTPUT : I/O UNIT 7; PADDED WITH BLANKS TO YIELD 80 CHARACTERS ALWAYS
  65. C     CONTROL OUTPUT: I/O UNIT 6 (NOT REALLY NECESSARY)
  66. C
  67. C     NO REWIND WILL BE PERFORMED ON EITHER INPUT OR OUTPUT BEFORE OR
  68. C     AFTER PROCESSING. OUTPUT FILE WILL HAVE A SINGLE FILE MARK AT END.
  69. C
  70. C     ALL VARIABLES ARE ASSUMED TO BE 32-BIT-QUANTITIES
  71. C
  72.       IMPLICIT INTEGER*4 (A-Z)
  73.       LOGICAL*4 ZFOUND,ZNULL
  74.       REAL*4 RATE
  75.       DIMENSION CHUNK(4),BYTES(3)
  76. C     INITIALIZATION OF SOME PSEUDO-CHARACTER CONSTANTS, EACH RIGHT-
  77. C     JUSTIFIED IN AN INTEGER VARIABLE:
  78. C     R6BITS HAS THE 6 RIGHT-MOST BITS SET; CZERO IS ASCII-0, AND
  79. C     CREP IS ASCII-TILDE:
  80.       DATA R6BITS/63/, CZERO/48/, CREP/126/
  81.       DATA LMAX/78/, NULL/0/, TWO/2/, FOUR/4/
  82. C --- I/O UNITS:
  83.       DATA INPUT/5/, OUTPUT/7/, CONTRL/6/
  84. C
  85. C --- INITIALISATION:
  86.       INCT = 0
  87.       INBYTE = 0
  88.       INPT = 0
  89.       NULLCT = 0
  90.       ZFOUND = .TRUE.
  91.       WRITE (CONTRL,10000)
  92. 10000 FORMAT (//' Conversion from binary to boo format starts.'/)
  93.       CALL WRINI(OUTPUT,OUTCT,OUTCHR,OUTPT)
  94. 10    CONTINUE
  95. C --- MAIN INPUT LOOP:
  96. C --- ASSEMBLE 3 BYTES:
  97.       CALL GETBYT(BYTES(1),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
  98.       IF (.NOT.ZFOUND) GOTO 200
  99. 12    ZNULL = BYTES(1).EQ.NULL
  100.       CALL GETBYT(BYTES(2),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
  101.       ZNULL = ZNULL .AND. BYTES(2).EQ.NULL
  102.       CALL GETBYT(BYTES(3),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
  103.       ZNULL = ZNULL .AND. BYTES(3).EQ.NULL
  104. 15    CONTINUE
  105.       IF (.NOT.ZNULL) GOTO 30
  106. C --- START NULL COMPRESSION:
  107.       I = 3
  108. 20    CONTINUE
  109.       I = I + 1
  110.       CALL GETBYT(BYTES(1),INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
  111.       IF ((BYTES(1).EQ.NULL) .AND. ZFOUND .AND. (I.LE.LMAX)) GOTO 20
  112. C --- END OF NULL SEQUENCE:
  113.       I = I - 1
  114.       NULLCT = NULLCT + I
  115.       CHUNK(1) = CREP
  116.       CHUNK(2) = I + CZERO
  117.       CALL WRCHAR(CHUNK,OUTPUT,OUTCT,OUTCHR,OUTPT,TWO)
  118.       IF (ZFOUND) GOTO 12
  119.       GOTO 200
  120. 30    CONTINUE
  121. C --- NON-NULL BYTES; SHIFT BITS TO FORM CHUNK:
  122.       CHUNK(1) = ISHFT(BYTES(1),-2) + CZERO
  123.       CHUNK(2) = IAND(IOR(ISHFT(BYTES(1),4),ISHFT(BYTES(2),-4)),
  124.      *                R6BITS) + CZERO
  125.       CHUNK(3) = IAND(IOR(ISHFT(BYTES(2),2),ISHFT(BYTES(3),-6)),
  126.      *                R6BITS) + CZERO
  127.       CHUNK(4) = IAND(BYTES(3),R6BITS) + CZERO
  128.       CALL WRCHAR(CHUNK,OUTPUT,OUTCT,OUTCHR,OUTPT,FOUR)
  129.       IF (ZFOUND) GOTO 10
  130. 200   CONTINUE
  131. C --- END OF FILE; FLUSH OUTPUT BUFFER BY PADDING WITH BLANKS:
  132.       CALL FLSHSO(OUTPUT,OUTCT,OUTPT)
  133.       RATE = 0.0
  134.       IF (OUTCHR.GT.0) RATE = (100.0*INBYTE) / OUTCHR
  135.       WRITE (CONTRL,19000) INCT,INBYTE,OUTCT,OUTCHR,NULLCT,RATE
  136. 19000  FORMAT (//' Number of  input sectors:',I9,
  137.      *         '; number of  input bytes:',I9
  138.      *        /' Number of output lines  :',I9,
  139.      *         '; number of output chars:',I9
  140.      *        /' Number of nulls         :',I9,
  141.      *         '; efficiency             :',F8.1,'%'/)
  142.       STOP
  143.       END
  144. C
  145. C
  146.       SUBROUTINE WRCHAR(CHUNK,OUTPUT,OUTCT,OUTCHR,OUTPT,NBR)
  147. C
  148. C     OUTPUT NBR CHARACTERS (CHUNK) TO OUTPUT;
  149. C     UPDATE LINES WRITTEN (OUTCT), CHARS WRITTEN (OUTCHR),
  150. C     POINTER TO OUTPUT LINE (OUTPT)
  151. C
  152. C     CALL WRINI FIRST FOR INITIALISATION.
  153. C     CALL FLSHSO FOR FINISHING OFF.
  154. C
  155.       IMPLICIT INTEGER*4 (A-Z)
  156.       DIMENSION CHUNK(1),OUTLIN(20),DUMNAM(3)
  157. C     MAXLGT IS MAXIMUM NUMBER OF CHARACTERS ALLOWED; LINLEN IS
  158. C     NUMBER OF 32-BIT-WORDS ACTUALLY WRITTEN (DIMENSION OF OUTLIN):
  159.       DATA MAXLGT/76/, LINLEN/20/
  160. C     CBLANK IS ASCII-BLANK, RIGHT-JUSTIFIED, BLANK4 IS 4 BYTES BLANK:
  161.       DATA CBLANK/32/, BLANK4/'    '/
  162. C --- SOME FORTRANS HAVE NO WAY OF KNOWING EXTERNAL FILES NAMES,
  163. C     HENCE SUPPLY DUMMY NAME:
  164.       DATA DUMNAM/'BINA','RY.D','AT  '/
  165. C
  166. C --- IS BUFFER FULL?
  167.       IF (OUTPT+NBR.LE.MAXLGT) GOTO 10
  168. C --- BUFFER IS INDEED FULL; PAD TO BUFFER LENGTH AND PUT IT OUT:
  169.       K = 4*LINLEN - 1
  170.       DO 5 I=OUTPT,K
  171. 5     CALL INSRCH(CBLANK,OUTLIN,I+1)
  172.       WRITE (OUTPUT,40000) OUTLIN
  173. C --- ADAPT IF NECESSARY:
  174. 40000 FORMAT (20A4)
  175.       OUTCT = OUTCT + 1
  176.       OUTPT = 0
  177. 10    CONTINUE
  178. C --- PUT IN CHARACTERS:
  179.       DO 20 I=1,NBR
  180.       OUTPT = OUTPT + 1
  181.       OUTCHR = OUTCHR + 1
  182.       CALL INSRCH(CHUNK(I),OUTLIN,OUTPT)
  183. 20    CONTINUE
  184.       GOTO 90
  185. C
  186. C     ENTRY WRINI:
  187. C
  188.       ENTRY WRINI(OUTPUT,OUTCT,OUTCHR,OUTPT)
  189. C
  190. C --- ALL INITIALIZATIONS NEEDED FOR THE OUTPUT FILE GO HERE:
  191. C --- WRITE DUMMY FILE NAME TO OUTPUT FILE, SINCE WE DON'T KNOW BETTER:
  192.       DO 30 I=1,3
  193. 30    OUTLIN(I) = DUMNAM(I)
  194.       K = 4*LINLEN
  195.       DO 35 I=13,K
  196. 35    CALL INSRCH(CBLANK,OUTLIN,I)
  197.       WRITE (OUTPUT,40000) OUTLIN
  198.       OUTCT = 0
  199.       OUTCHR = 0
  200.       OUTPT = 0
  201.       GOTO 90
  202. C
  203. C --- ENTRY FLSHSO:
  204. C
  205.       ENTRY FLSHSO(OUTPUT,OUTCT,OUTPT)
  206. C
  207. C --- ANYTHING TO CLOSE THE OUTPUT FILE GOES HERE:
  208.       K = 4*LINLEN - 1
  209.       DO 50 I=OUTPT,K
  210. 50    CALL INSRCH(CBLANK,OUTLIN,I+1)
  211. C --- WRITE THE REST:
  212.       WRITE (OUTPUT,40000) OUTLIN
  213.       OUTCT = OUTCT + 1
  214. C --- ANYTHING TO CLOSE THE OUTPUT FILE:
  215.       ENDFILE OUTPUT
  216. 90    CONTINUE
  217.       RETURN
  218.       END
  219. C
  220. C
  221.       SUBROUTINE GETBYT(BYTE,INPUT,INCT,INBYTE,INPT,CONTRL,ZFOUND)
  222. C
  223. C     GET ONE BYTE FROM INPUT; UPDATE COUNT OF SECTORS (INCT),
  224. C     COUNT OF INPUT BYTES(INBYTE) (EVEN IF THAT'S NEARLY REDUNDANT...)
  225. C     AND POINTER INTO INPUT BUFFER (INPT).
  226. C     ZFOUND IS TRUE IFF BYTE WAS FOUND.
  227. C     REPORT PROGRESS ON UNIT CONTRL.
  228. C
  229.       IMPLICIT INTEGER*4 (A-Z)
  230.       LOGICAL*4 ZFOUND
  231. C --- UFT IS NEEDED FOR MODCOMP BINARY READ:
  232.       DIMENSION SECTOR(64),UFT(5)
  233. C     THESE VARIABLES ARE FOR MODCOMP USE ONLY:
  234.       DATA OPTION/36864/, EOFBIT/2097152/
  235. C --- SECLEN IS NUMBER OF BYTES IN A TYPICAL, FIXED-LENGTH BINARY RECORD:
  236.       DATA SECLEN/256/
  237. C
  238.       BYTE = 0
  239.       IF (.NOT.ZFOUND) GOTO 95
  240. C --- CHECK IF FIRST CALL:
  241.       IF (INCT.NE.0) GOTO 10
  242. C --- YES; ANYTHING TO INITIALIZE INPUT FILE FOR READING GOES HERE;
  243. C     READING MUST BE UNDISTURBED BY ANY CONTROL CHARACTERS:
  244. C --- INITIALIZE UFT FOR READING (MODCOMP; REPLACE WITH WHATEVER YOU
  245. C     NEED):
  246. C
  247.       CALL BLDUFT(UFT,0,ICAN4(INPUT),OPTION)
  248. C
  249.       GOTO 12
  250. 10    CONTINUE
  251. C --- IS SOMETHING LEFT IN THE BUFFER?
  252.       IF (INPT.LT.SECLEN) GOTO 20
  253. C --- NO; GET NEXT SECTOR:
  254. 12    INCT = INCT + 1
  255. C --- DO A BINARY READ OF SECLEN BYTES = ONE RECORD:
  256. C     (AGAIN, REPLACE WITH WHATEVER YOU NEED, MAYBE A PLAIN READ WITH
  257. C     FORMAT (64A4) WILL DO FOR YOU. REMEMBER TO CHECK FOR END OF FILE.)
  258. C
  259.       CALL READ4(UFT,SECTOR,SECLEN)
  260. C
  261. C --- END OF FILE??
  262.       IF (IAND(UFT(1),EOFBIT).NE.0) GOTO 90
  263. C --- NO; NEXT SECTOR FOUND:
  264. C --- REPORT PROGRESS ON CONTROL UNIT FROM TIME TO TIME:
  265.       IF (MOD(INCT,64).EQ.0) WRITE (CONTRL,17000) INCT
  266. 17000 FORMAT ('+Record',I9)
  267.       INPT = 0
  268. 20    CONTINUE
  269. C --- GET NEXT BYTE FROM BUFFER:
  270.       INPT = INPT + 1
  271.       INBYTE = INBYTE + 1
  272.       CALL EXTRCH(BYTE,SECTOR,INPT)
  273.       GOTO 95
  274. 90    CONTINUE
  275.       ZFOUND = .FALSE.
  276. 95    CONTINUE
  277.       RETURN
  278.       END
  279. C
  280. C
  281.       SUBROUTINE EXTRCH(C,BUFFER,POS)
  282. C
  283. C     GET POS-TH BYTE FROM BUFFER, RETURN IT RIGHT-JUSTIFIED WITHIN C:
  284. C     BUFFER IS REGARDED AS TIGHTLY PACKED 32-BIT-QUANTITIES-ARRAY
  285. C
  286.       IMPLICIT INTEGER*4 (A-Z)
  287.       DIMENSION BUFFER(1)
  288. C     THESE ARE THE RIGHT-MOST 8 BITS:
  289.       DATA RBYTE/255/
  290. C
  291.       I = (POS+3) / 4
  292.       K = POS - 4*(I-1)
  293.       C = BUFFER(I)
  294. C --- NOW SHIFT; BUT FOR THE BENEFIT OF SOME FAULTY COMPILERS,
  295. C     DONT'T IF SHIFT COUNT IS 0:
  296.       IF (K.NE.4) C = ISHFT(C,8*K-32)
  297.       C = IAND(C,RBYTE)
  298.       RETURN
  299.       END
  300. C
  301. C
  302.       SUBROUTINE INSRCH(C,BUFFER,POS)
  303. C
  304. C     INSERT RIGHT-MOST BYTE OF C INTO POS-TH BYTE OF BUFFER.
  305. C     ASSUME C IS 0 IN 3 FIRST BYTES AND THERE ARE NO SIGNIFICANT BYTES
  306. C     AFTER POS IN BUFFER
  307. C     BUFFER IS REGARDED AS TIGHTLY PACKED 32-BIT-QUANTITIES-ARRAY
  308. C
  309.       IMPLICIT INTEGER*4 (A-Z)
  310.       DIMENSION BUFFER(1)
  311. C     THIS IS A VARIABLE WITH EACH AND EVERY BIT SET; IF YOUR MACHINE
  312. C     DOESN'T USE TWO'S COMPLEMENT, YOU GOT TO FIGURE OUT HOW TO DO IT:
  313.       DATA FULLBT/-1/
  314. C
  315.       I = (POS+3)/4
  316.       K = POS - 4*(I-1)
  317.       CA = C
  318. C --- NOW SHIFT; BUT FOR THE BENEFIT OF SOME FORTRAN COMPILERS,
  319. C     DON'T IF SHIFT COUNT IS ZERO:
  320.       IF (K.NE.4) CA = ISHFT(CA,32-8*K)
  321.       MASK = ISHFT(FULLBT,40-8*K)
  322.       BUFFER(I) = IOR(IAND(BUFFER(I),MASK),CA)
  323.       RETURN
  324.       END
  325.