home *** CD-ROM | disk | FTP | other *** search
/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / general / readtape.for < prev    next >
Encoding:
Text File  |  1988-05-03  |  9.8 KB  |  276 lines
  1. C
  2. C THIS FORTRAN-77 PROGRAM WAS DEVELOPED TO ALLOW VAX/VMS COMPUTERS TO
  3. C READ THE "ALMOST-ANSI-STANDARD" ADA SOURCE CODE REPOSITORY TAPES.
  4. C
  5. C
  6. C IT WAS DEVELOPED BY CHARLES A. FINNELL AND HARRY E. JEGERS OF
  7. C
  8. C                     ADA SYSTEMS BRANCH
  9. C                 TELEDYNE BROWN ENGINEERING
  10. C                   788 SHREWSBURY AVENUE
  11. C                  TINTON FALLS, NJ 07724
  12. C                      (201) 741-5008
  13. C
  14. C
  15. C WE CALLED IT "READ-TAPE-USING-QIOW.FOR" ON OUR VAX/VMS 4.2 SYSTEM.
  16. C
  17. C THIS PROGRAM DOES NOT REFLECT OUR KNOWLEDGE OF GOOD FORTRAN STYLE.
  18. C IT WAS HACKED TOGETHER FROM SCRATCH OVER A TWO WEEK PERIOD (JAN86)
  19. C DURING WHICH WE GRADUALLY DISCOVERED WHAT WORKED AND WHAT DIDN'T.
  20. C DESPITE ITS APPEARANCE, THIS PROGRAM SUCCESSFULLY READ BOTH OF THE
  21. C "ALMOST-ANSI-STANDARD  TAPES SHIPPED AS COPIES OF THE MASTER TAPE
  22. C PRODUCED BY "WRITEL" IN DECEMBER 1985.
  23. C
  24. C USAGE NOTES:
  25. C FIRST YOU NEED TO COMPILE AND LINK THIS PROGRAM BY ISSUING THE
  26. C FOLLOWING DCL COMMANDS:
  27. C
  28. C $ FORTRAN READ-TAPE-USING-QIOW
  29. C $ LINK    READ-TAPE-USING-QIOW
  30. C
  31. C IF THIS SUCCEEDS, GET YOUR SYSTEM MANAGER TO "$ RUN AUTHORIZE"
  32. C AND GIVE YOU THE "VOLPRO" PRIVILEGE, WHICH YOU NEED TO READ
  33. C THE TAPES WE GOT, AND PHYSICALLY MOUNT THE FIRST TAPE IN YOUR
  34. C TAPE DRIVE.
  35. C
  36. C NEXT ISSUE THE FOLLOWING DCL COMMANDS, REPLACING "MSAO:" BY
  37. C THE NAME OF YOUR TAPE DRIVE:
  38. C
  39. C $ SET PROCESS/PRIV=VOLPRO
  40. C $ MOUNT/NOWRITE/OVERRIDE=(OWNER,ACCESS)/FOREIGN MSAO: ADA TAPE
  41. C
  42. C IF THIS SUCCEEDS, RUN THIS PROGRAM AS FOLLOWS:
  43. C
  44. C $ RUN READ-TAPE-USING-QIOW
  45. C
  46. C THIS PROGRAM WILL TAKE SEVERAL HOURS TO RUN (4 HRS. ON OUR VAX 11/730)
  47. C AND WILL COPY ALMOST 45,000 512-BYTE BLOCKS OF DATA INTO THE DEFAULT
  48. C DIRECTORY.  NOTE THAT THE BIG FILE "SP2MASTER.DCT" EXISTS PARTLY
  49. C ON THE END OF THE FIRST TAPE AND PARTLY ON THE BEGINNING OF THE
  50. C SECOND TAPE.  YOU WILL EVENTUALLY NEED TO USE THE FOLLOWING DCL
  51. C COMMAND TO COMBINE THESE TWO PIECES:
  52. C
  53. C $ COPY/LOG SP2MASTER.DCT;l,SP2MASTER.DCT;2 SP2MASTER.DCT;3
  54. C
  55. C NOTE THAT THE HIERARCHICAL STRUCTURE OF THE SIMTEL20 DIRECTORIES
  56. C WAS LOST WHEN THE "ALMOST-ANSI-STANDARD" TAPES WERE MADE.  YOU WILL
  57. C HAVE TO USE "$ CREATE" TO MAKE SOME SUBDIRECTORIES AND "$ RENAME"
  58. C TO MOVE THE FILES UNDER THE APPROPRIATE SUBDIRECTORIES IF YOU WANT
  59. C TO ORGANIZE THE FILES AS SPECIFIED ON THE DOCUMENTATION THAT
  60. C WAS SUPPLIED WITH THE TAPE.  USE THE DISK FILE CREATION TIMES AS
  61. C A GUIDE TO MAKE SURE YOU GET EACH FILE INTO THE PROPER SUBDIRECTORY.
  62. C
  63. C PLEASE FEEL FREE TO USE THIS PROGRAM FOR ANY PURPOSE WHATSOEVER.
  64. C
  65.        CHARACTER*1  REC FORM
  66.        CHARACTER*5  BLCK LEN, REC LEN
  67.        CHARACTER*17 FILENM
  68.        CHARACTER*80 LABEL
  69.        CHARACTER*2000 BUFFER
  70.  
  71.        PARAMETER EOF = '870'X !END OF FILE MARK
  72.        PARAMETER IO$READLBLK = '21'X ! READ LOGICAL BLOCK CODE FOR QIOW
  73.        PARAMETER IO$REWIND = '24'X ! REWIND CODE FOR QIOW
  74.  
  75.        PARAMETER NOLOGNAM = '908'X ! RETURN CODE FOR NO ASSIGNED LOGILCAL NAME
  76.        PARAMETER NOPRIV = '24' X ! RETURN CODE FOR IMPROPER SET UP OR PRIV.
  77.  
  78.        PARAMETER LABSIZE = 80
  79.        PARAMETER BUFSIZE = 2000
  80.  
  81.        INTEGER*2 CHANO, IOSB(4), BUFLEN
  82.        INTEGER*4 SYS$ASSIGN, SYS$QIOW, RETCODE
  83.        INTEGER*2 VLRLEN,VLRNDX
  84.  
  85.        INTEGER COUNT, WRTCOUNT
  86.  
  87.        DATA WRTCOUNT/0/
  88.  
  89. C ASSIGN THE TAPE DRIVE SO THE TAPE CAN BE READ :
  90.        RETCODE = SYS$ASSIGN('TAPE', CHANO,,)
  91.        IF (RETCODE.NE.1) GOTO 2000
  92.  
  93. C REWIND THE TAPE AND PREPARE TO READ IT :
  94.        RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$REWIND), IOSB,,,,,,,,)
  95.        IF (RETCODE.NE.1) GOTO 2000
  96.  
  97. C READ FIRST LABEL (VOLUME LABEL) :
  98. 20     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
  99.      1                    %REF(LABEL(1:1)), %VAL(LABSIZE),,,,)
  100.        IF (RETCODE.NE.1) GO TO 21
  101.        IF (LABEL(1:7).EQ.'VOL1ADA') THEN
  102.          WRITE(6,23) LABEL(1:7)
  103. 23       FORMAT(1X, 'The volume label on this tape is : ', A8)
  104.          GO TO 30
  105.       ENDIF
  106.  
  107. C HANDLE ANY ERROR IN READING THE FIRST LABEL ON THE TAPE
  108. 21     WRITE(6,24) LABEL(1:7)
  109. 24     FORMAT(1X, '*** VOLUME LABEL ERROR : The label is - ', A8)
  110.        GO TO 3000
  111.  
  112. C READ THE SECOND LABEL (FIRST HEADER CONTAINING THE FILE NAME OF THE
  113. C SOURCE CODE TO BE READ.
  114. 30     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
  115.      1                    %REF(LABEL(1:1)), %VAL(LABSIZE),,,,)
  116.        IF (RETCODE.NE.1) GO TO 31
  117.        IF (IOSB(1).EQ.EOF) GO TO 32
  118.        IF ((LABEL(1:4).EQ.'EOF1').OR.(LABEL(1:4).EQ.'EOF2').OR.
  119.      1     (LABEL(1:4).EQ.'EOV1').OR.(LABEL(1:4).EQ.'EOV2')) THEN
  120.          COUNT = 0
  121.          WRITE(6,200) LABEL(1:4)
  122. 200      FORMAT(1X,'--- Found an ',A,' record ---')
  123.          GO TO 30
  124.        ENDIF
  125.        IF (LABEL(1:4).EQ.'HDR1') THEN
  126.          FILENM = LABEL(5:21)
  127.          DO I=1,17                             ! added
  128.            IF(FILENM(I:I) .EQ. '-' )THEN       ! added
  129.              FILENM(I:I) = '_'                 ! added
  130.            END IF                              ! added
  131.          END DO                                ! added
  132.          WRITE(6,33) FILENM
  133. 33       FORMAT(1X,'>>>> The name of this file is : ', A17)
  134.          GO TO 40
  135.         ELSE
  136.          GO TO 30
  137.         ENDIF
  138.  
  139. C HANDLE ANY ERROR IN READING THE NEXT LABEL ON THE TAPE
  140. 31     WRITE(6,34) LABEL(1:21)
  141. 34     FORMAT(1X, '*** ERROR IN THE FILE NAME : The label is - ', A21)
  142.        GO TO 3000
  143.  
  144. C KEEP TRACK OF EOF (TAPE) MARKS ON THE TAPE, IF TWO IN A ROW ARE
  145. C REACHED THE STOP READING THE TAPE.  IF THERE ARE MORE THAN TWO MARKS
  146. C IN A ROW THERE IS AN ERROR.
  147. 32     IF (COUNT.EQ.1) THEN
  148.          WRITE(6,35)
  149. 35       FORMAT(1X,'--- Reached two tape marks in a row (EOT) ---')
  150.          GOTO 3050
  151.        ELSE
  152.          IF (COUNT.GE.2) THEN
  153.            WRITE(6,36)
  154. 36         FORMAT(1X, '*** ERROR IN TAPE; TOO MANY EOF MARKS ***')
  155.          ELSE
  156.            WRITE(6,37)
  157. 37         FORMAT(1X, '--- Reached a tape mark (EOF) ---')
  158.            COUNT = COUNT + 1
  159.            GO TO 30
  160.          ENDIF
  161.        ENDIF
  162.        GO TO 3000
  163.  
  164. C READ THE SECOND HEADER CONTAINING SOME LESS IMPORTANT INFORMATION
  165. 40     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
  166.      1                    %REF(LABEL(1:1)), %VAL(LABSIZE),,,,)
  167.        IF (RETCODE.NE.1) GO TO 41
  168.        IF (LABEL(1:4).EQ.'HDR2') THEN
  169.          REC FORM = LABEL(5:5)
  170.          BLCK LEN = LABEL(6:10)
  171.          REC LEN  = LABEL(11:15)
  172.          WRITE(6,43) REC FORM, BLCK LEN, REC LEN 
  173. 43       FORMAT(1X,'REC FORM = ',A1,' BLCK LEN = ',A5,' REC LEN = ',A5)
  174.          COUNT = 0
  175.          GO TO 49
  176.        ELSE
  177.          GO TO 40
  178.        ENDIF
  179.  
  180. C HANDLE ANY ERROR WHEN READING THE THIRD LABEL ON THE TAPE
  181. 41     WRITE(6,44) LABEL(1:15)
  182. 44     FORMAT(1X, '*** ERROR IN THE FILE CHARACTERISTICS : ',
  183.      1'The label is - ', A15)
  184.        GO TO 3000
  185.  
  186. C CREATE THE FILE TO CONTAIN THE DATA FROM THE TAPE, MAKING SURE
  187. C THAT THE DISK FILE WILL HAVE THE SAME FORMAT AS NORMAL DISK
  188. C FILES CREATED BY THE "EDT" EDITOR:
  189. 49     OPEN(UNIT=30, CARRIAGECONTROL='LIST', RECORDTYPE='VARIABLE',
  190.      1 FORM='UNFORMATTED', FILE=FILENM, STATUS='NEW', ERR=53)
  191.  
  192. C EXTRACT THE SOURCE LISTINGS FROM THE TAPE :
  193. 50     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
  194.      1                    %REF(BUFFER(1:1)), %VAL(BUFSIZE),,,,)
  195.        IF (RETCODE.NE.1) GO TO 52
  196.        IF (IOSB(1).EQ.EOF) GO TO 51
  197.        BUFLEN = IOSB(2)
  198.        IF (WRTCOUNT.LT.20) THEN
  199.          WRITE(6,61) BUFLEN
  200. 61       FORMAT(1X,'BUFLEN = ',I5,' BUFFER(1:80) = ')
  201.          WRITE(6,54) BUFFER(1:80)
  202. 54       FORMAT(1X,A)
  203.          WRTCOUNT = WRTCOUNT + 1
  204.        ENDIF
  205.  
  206. C      >------> DEBLOCK THE VARYING-LENGTH RECORDS:
  207.        VLRNDX = 1
  208. 100    CONTINUE
  209.        IF (VLRNDX+3.GT.BUFLEN) GOTO 50
  210.        DECODE(4, 105, BUFFER(VLRNDX:VLRNDX+3), ERR=110) VLRLEN
  211. 105    FORMAT(I4)
  212.        IF ((1.LE.VLRNDX+4) .AND. (VLRNDX+4.LE.VLRNDX+VLRLEN-1) .AND.
  213.      1   (VLRNDX+VLRLEN-1.LE.BUFLEN)) THEN
  214. C        WRITE OUT A LOGICAL RECORD IF IT HAS AT LEAST ONE DATA BYTE:
  215.          WRITE(UNIT=30, ERR=55) BUFFER(VLRNDX+4:VLRNDX+VLRLEN-1)
  216.        ELSE
  217. C        WRITE(6,60) VLRNDX, VLRLEN,.BUFLEN
  218. C60      FORMAT(1X,'*> VLRNDX = ',I5,' VLRLEN = ',I5,' BUFLEN = ',I5)
  219. C        WRITE A NULL RECORD (BLANK LINE) WHERE NECESSARY:
  220.          WRITE(UNIT=30, ERR=55)
  221.       ENDIF
  222. 62     CONTINUE
  223.        VLRNDX = VLRNDX + VLRLEN
  224.        GOTO 100
  225.  
  226. C      HANDLE ANY ERRORS FROM DECODE (WE NEVER GOT ANY):
  227. 110    WRITE(6,120) VLRNDX, VLRLEN, BUFLEN
  228. 120    FORMAT(1X,'*D*> VLRNDX = ',I5,' VLRLEN = ',I5,' BUFLEN = ',I5)
  229.        GOTO 50
  230.  
  231. C KEEP TRACK OF EOF (TAPE) MARKS
  232. 51     COUNT = COUNT + 1
  233.        WRITE(6,56) COUNT
  234. 56     FORMAT(1X, 'Reached EOF (Tape) mark; COUNT = ', I4)
  235.        IF (COUNT.EQ.1) THEN
  236.          GO TO 50
  237.        ELSE
  238.          IF (COUNT.EQ.2) CLOSE(UNIT=30)
  239.          IF (COUNT.EQ.2) GO TO 30
  240.        ENDIF
  241.        GO TO 3000
  242.  
  243. C HANDLE ANY ERROR IN READING FROM THE TAPE
  244. 52     WRITE(6,57)
  245. 57     FORMAT(1X, '*** ERROR IN READING THE TAPE ***')
  246.        GO TO 3000
  247.  
  248. C HANDLE ANY ERROR IN OPENING THE NEW FILE
  249. 53     WRITE(6,58) FILENM
  250. 58     FORMAT(1X, '*** ERROR IN OPENING OUTPUT FILE : ', A16,' ***')
  251.        GO TO 3000
  252.  
  253. C HANDLE ANY ERROR IN WRITING THE SOURCE TO A NEW FILE
  254. 55     WRITE(6,59) FILENM
  255. 59     FORMAT(1X, '*** ERROR IN WRITING TO FILE : ', A16, ' ***')
  256.        GOTO 62
  257.  
  258. 2000   IF (RETCODE.NE.1) THEN
  259.          IF (RETCODE.EQ.NOLOGNAM) THEN
  260.           WRITE(6,2010)
  261. 2010       FORMAT(1X, '*** ASSIGN LOGICAL NAME "TAPE" ***')
  262.          ENDIF
  263.          IF (RETCODE.EQ.NOPRIV) THEN
  264.            WRITE(6,2020)
  265. 2020       FORMAT(1X, '*** TAPE MUST BE MOUNTED FOREIGN ***')
  266.          ENDIF
  267.        ENDIF
  268. 3000   CONTINUE
  269.        WRITE(6,3005) RETCODE
  270. 3005   FORMAT(1X,'RETCODE = ', I5)
  271.        WRITE(6,3010)
  272. 3010   FORMAT(1X, '*** TAPE READING TERMINATED ***')
  273.        CALL LIB$STOP(%VAL(RETCODE))
  274. 3050   CONTINUE
  275.        END
  276.