Trailing-Edge
-
PDP-10 Archives
-
tops10_integ_tools_v4_10jan-86
-
70,6067/dumpr1/dumper.txt
There are 3 other files named dumper.txt in the archive. Click here to see a list.
.TITLE ALLDEF
$MTDEF GLOBAL
$TPADEF GLOBAL
.END
SUBROUTINE COMMAND(COMLINE,STATE,KEY,STATUS)
C
C This subroutine processes a command line by calling
C the LIB$TPARSE run-time library routines. It will
C create a "standard" parameter block for LIB$TPARSE,
C and then call it. Any status code returned by
C LIB$TPARSE will be returned as STATUS.
C
C This version uses the following LIB$TPARSE options:
C TPA$M_BLANKS = off, treat blanks as separators
C TPA$M_ABBRFM = off, abbreviations must be unique
C TPA$M_ABBREV = on, abbreviations are allowed
C
C COMLINE -- Command line to parse
C STATE -- State table address
C KEY -- Keyword table address
C STATUS -- Integer status of command
C
IMPLICIT COMPLEX (A-Z)
C
CHARACTER COMLINE*(*)
INTEGER*4 STATE,KEY
INTEGER*4 STATUS
C
INTEGER*4 LIB$TPARSE
C
C The parameter block for LIB$TPARSE
C
INTEGER*4 TPBLOK(0:8)
EXTERNAL TPA$L_COUNT,TPA$L_OPTIONS,TPA$L_STRINGCNT
EXTERNAL TPA$L_STRINGPTR,TPA$L_TOKENCNT,TPA$L_TOKENPTR
EXTERNAL TPA$B_CHAR,TPA$L_NUMBER,TPA$L_PARAM
EXTERNAL TPA$M_BLANKS,TPA$M_ABBRFM,TPA$M_ABBREV
EXTERNAL TPA$M_AMBIG,TPA$K_COUNT0
C
C Initialize the LIB$TPARSE parameter block
C
TPBLOK(%LOC(TPA$L_COUNT)/4) = %LOC(TPA$K_COUNT0)
TPBLOK(%LOC(TPA$L_OPTIONS)/4) = %LOC(TPA$M_ABBREV)
TPBLOK(%LOC(TPA$L_STRINGCNT)/4) = LEN(COMLINE)
TPBLOK(%LOC(TPA$L_STRINGPTR)/4) = %LOC(COMLINE)
STATUS = LIB$TPARSE(TPBLOK,STATE,KEY)
IF (.NOT.STATUS) THEN
CALL ERRORM(STATUS)
WRITE(6,100) COMLINE
100 FORMAT(1X,A)
WRITE(6,110)
110 FORMAT(<TPBLOK(%LOC(TPA$L_STRINGPTR)/4)-%LOC(COMLINE)+1>X,'^')
ENDIF
RETURN
END
.TITLE CVT CONVERT DEC-10 DATATYPES FOR VAX
;+
; CVT -- A SUBROUTINE PACKAGE FOR THE DUMPER/BACKUP
; TAPE READING UTILITIES. THESE SUBROUTINES CONVERT
; DEC-10 DATATYPES INTO THOSE USABLE ON THE VAX.
;
; ENTRY POINTS:
; CVT36 TO CONVERT 5 BYTE DEC-10 MAGTAPE RECORDS INTO
; THE PROPERLY ALIGNED 36 BIT VALUES (2 WORDS
; PER VALUE)
; CVT72 TO CONVERT 9 BYTE CCC TU70 DEC-10 MAGTAPE RECORDS
; INTO THE PROPERLY ALIGNED 36 BIT VALUES (2 WORDS
; PER VALUE DONE 2 AT A TIME).
; CVTASZ TO CONVERT ASCIZ STRINGS TO 8 BIT ASCII DATA
; AND TO APPEND IT TO THE SUPPLIED STRING.
; CVTHALF TO CONVERT 18 BIT HALFWORDS TO TWO LONGWORD
; INTEGERS.
; CVTSIX TO CONVERT A SIX SIXBIT CHARACTERS TO 8 BIT
; ASCII AND TO APPEND IT TO THE SUPPLIED STRING
; COPY5 TO COPY THE OUTPUT OF CVT36 OR CVT72 INTO A
; BYTE STREAM
; COPYASC TO COPY 7-BIT ASCII DATA INTO A BYTE STREAM.
;-
; COMPBS TO COMPARE A BYTE ARRAY TO A STRING
.ENTRY CVT36,^M<R2,R3,R4>
;+
; ENTRY POINT: CVT36
; CALLING SEQUENCE:
; CALL CVT36(A,B,C)
; A -- A BYTE ARRAY CONTAINING THE DATA TO BE CONVERTED
; B -- A 2 BY C LONGWORD ARRAY TO RECIEVE THE DATA.
; C -- THE NUMBER OF WORDS TO CONVERT
;-
MOVL 4(AP),R3 ;GET THE INPUT ADDRESS
MOVL 8(AP),R4 ;GET THE OUTPUT ADDRESS
MOVL @12(AP),R2 ;AND THE COUNT
CVTL:
INSV (R3),#28,#8,(R4) ;NOW MOVE THINGS AROUND
INSV 1(R3),#20,#8,(R4) ;LIKE SO...
INSV 2(R3),#12,#8,(R4)
INSV 3(R3),#4,#8,(R4)
INSV 4(R3),#0,#4,(R4)
ADDL2 #5,R3 ;MOVE ALONG TO NEXT 36-BIT WORD
ADDL2 #8,R4 ;AND TO NEXT QUADWORD
SOBGTR R2,CVTL
RET
.ENTRY CVT72,^M<R2,R3,R4>
;+
; ENTRY POINT: CVT72
; CALLING SEQUENCE:
; CALL CVT72(A,B,C)
; A -- A BYTE ARRAY CONTAINING THE DATA TO BE CONVERTED
; B -- A 2 BY C LONGWORD ARRAY TO RECIEVE THE DATA.
; C -- THE NUMBER OF WORDS TO CONVERT
;-
MOVL 4(AP),R3 ;GET THE INPUT ADDRESS
MOVL 8(AP),R4 ;GET THE OUTPUT ADDRESS
MOVL @12(AP),R2 ;AND THE COUNT
ASHL #-1,R2,R2
CVTL2:
INSV (R3),#28,#8,(R4) ;NOW MOVE THINGS AROUND
INSV 1(R3),#20,#8,(R4) ;LIKE SO...
INSV 2(R3),#12,#8,(R4)
INSV 3(R3),#4,#8,(R4)
EXTZV #4,#4,4(R3),R0
INSV R0,#0,#4,(R4)
INSV 4(R3),#32,#4,8(R4)
INSV 5(R3),#24,#8,8(R4)
INSV 6(R3),#16,#8,8(R4)
INSV 7(R3),#8,#8,8(R4)
INSV 8(R3),#0,#8,8(R4)
ADDL2 #9,R3 ;MOVE ALONG TO NEXT 72-BIT WORD
ADDL2 #16,R4 ;AND TO NEXT PAIR OF QUADWORDS
SOBGTR R2,CVTL2
RET
.ENTRY CVTASZ,^M<R2,R3>
;+
; ENTRY POINT: CVTASZ
; CALLING SEQUENCE:
; CALL CVTASZ(DAT,LINE,LINEL)
; DAT -- IS THE START OF THE 2 BY N LONGWORD ARRAY
; THAT CONTAINS THE ASCIZ STRING
; LINE -- A BYTE ARRAY TO RECIEVE THE DATA
; LINEL -- THE INDEX TO THE BYTE ARRAY
;-
DAT = 4
LINE = 8
LINEL = 12
;
MOVAL @DAT(AP),R0
MOVAL @LINE(AP),R1
ADDL2 @LINEL(AP),R1
DECL R1
CAL:
EXTZV #29,#7,(R0),R2
TSTL R2
BEQL CAE
MOVB R2,(R1)+
INCL @LINEL(AP)
EXTZV #22,#7,(R0),R2
TSTL R2
BEQL CAE
MOVB R2,(R1)+
INCL @LINEL(AP)
EXTZV #15,#7,(R0),R2
TSTL R2
BEQL CAE
MOVB R2,(R1)+
INCL @LINEL(AP)
EXTZV #8,#7,(R0),R2
TSTL R2
BEQL CAE
MOVB R2,(R1)+
INCL @LINEL(AP)
EXTZV #1,#7,(R0),R2
TSTL R2
BEQL CAE
MOVB R2,(R1)+
INCL @LINEL(AP)
ADDL2 #8,R0
BRB CAL
;
CAE:
RET
.ENTRY CVTHALF,0
;+
; ENTRY POINT: CVTHALF
; CALLING SEQUENCE:
; CALL CVTHALF(DAT,RH,LH)
; DAT IS THE DATA TO BE CONVERTED
; RH IS THE RIGHT HALF (LOW ORDER) 18 BITS OF DAT
; LH IS THE LEFT HALF (HIGH ORDER) 18 BITS OF DAT
;-
DAT = 4
RH = 8
LH = 12
;
MOVAL @DAT(AP),R0
EXTZV #0,#18,(R0),R1
MOVL R1,@RH(AP)
EXTZV #18,#18,(R0),R1
MOVL R1,@LH(AP)
RET
.ENTRY CVTSIX,0
;+
; ENTRY POINT: CVTSIX
; CALLING SEQUENCE:
; CALL CVTSIX(DAT,LINE,LINEL)
; DAT -- THE QUADWORD CONTAINING THE SIXBIT DATA
; LINE -- THE LINE TO APPEND THE STRING TO
; LINEL -- THE CURRENT LENGTH OF THE LINE
;-
MOVAL @LINE(AP),R0
ADDL2 @LINEL(AP),R0
DECL R0
;
EXTZV #30,#6,@DAT(AP),R1
ADDL2 #32,R1
MOVB R1,(R0)+
EXTZV #24,#6,@DAT(AP),R1
ADDL2 #32,R1
MOVB R1,(R0)+
EXTZV #18,#6,@DAT(AP),R1
ADDL2 #32,R1
MOVB R1,(R0)+
EXTZV #12,#6,@DAT(AP),R1
ADDL2 #32,R1
MOVB R1,(R0)+
EXTZV #6,#6,@DAT(AP),R1
ADDL2 #32,R1
MOVB R1,(R0)+
EXTZV #0,#6,@DAT(AP),R1
ADDL2 #32,R1
MOVB R1,(R0)+
ADDL2 #6,@LINEL(AP)
RET
.ENTRY COPY5,^M<R2,R3,R4>
;+
; ENTRY POINT: COPY5
; CALLING SEQUENCE:
; CALL COPY5(A,B,C)
; A -- A 2 BY C LONGWORD ARRAY WITH THE DATA.
; B -- A BYTE ARRAY TO RECIEVE THE DATA
; C -- THE NUMBER OF WORDS TO CONVERT
;-
A = 4
B = 8
C = 12
;
MOVL @C(AP),R0
MOVAL @A(AP),R1
MOVAL @B(AP),R2
C5L:
MOVL (R1),(R2)+
MOVB 4(R1),(R2)+
ADDL2 #8,R1
SOBGTR R0,C5L
RET
.ENTRY COPYASC,^M<R2,R3>
;+
; ENTRY POINT: COPYASC
; CALLING SEQUENCE:
; CALL CVTASZ(DAT,LINE,NUM)
; DAT -- IS THE START OF THE 2 BY N LONGWORD ARRAY
; THAT CONTAINS THE ASCIZ STRING
; LINE -- A BYTE ARRAY TO RECIEVE THE DATA
; NUM -- THE NUMBER OF 5 BYTE WORDS TO PROCESS
;-
DAT = 4
LINE = 8
NUM = 12
;
MOVAL @DAT(AP),R0
MOVAL @LINE(AP),R1
MOVL @NUM(AP),R2
CAC:
EXTZV #29,#7,(R0),R3
MOVB R3,(R1)+
EXTZV #22,#7,(R0),R3
MOVB R3,(R1)+
EXTZV #15,#7,(R0),R3
MOVB R3,(R1)+
EXTZV #8,#7,(R0),R3
MOVB R3,(R1)+
EXTZV #1,#7,(R0),R3
MOVB R3,(R1)+
ADDL2 #8,R0
SOBGTR R2,CAC
RET
.ENTRY COMPBS,^M<R2,R3,R4>
;+
; ENTRY POINT: COMPBS
; CALLING SEQUENCE:
; CALL COMPBS(N,BYTES,STRING)
; N -- NUMBER OF BYTES TO COMPARE
; BYTES -- BYTE ARRAY TO COMPARE
; STRING -- CHARACTER STRING TO COMPARE
;-
MOVAL @12(AP),R1
CMPC3 @4(AP),@8(AP),@4(R1)
BNEQ NOTEQ
MOVL #-1,R0
RET
NOTEQ: MOVL #0,R0
RET
;
.END
SUBROUTINE CVTDATE(DATE,LINE,LINEL)
C
C TO CONVERT UNIVERSAL DATE/TIME FOR THE DEC-10
C INTO A PRINTABLE STRING. THE UNIVERSAL DATE
C TIME IS:
C LEFT HALF -- NUMBER OF DAYS FROM 17-NOV-1858
C RIGHT HALF -- FRACTIONAL DAY
C
INTEGER DATE(2)
BYTE LINE(256)
INTEGER LINEL
INTEGER DAYS,FRAC
INTEGER IDAY,IDAYS,YEAR,HOUR,MIN,ISECS,LEAP,QUADS
CHARACTER MONTH*3
REAL SECS
BYTE CDATE(20)
CHARACTER*20 DATEC
EQUIVALENCE (DATEC,CDATE)
C
CALL CVTHALF(DATE,FRAC,DAYS)
DAYS = DAYS+321
QUADS = DAYS/1461
DAYS = DAYS-QUADS*1461
YEAR = QUADS*4
LEAP = 0
IF (DAYS.GT.1095) THEN
YEAR = YEAR+1861
DAYS = DAYS-1096
ELSE IF (DAYS.GT.730) THEN
YEAR = YEAR+1860
DAYS = DAYS-730
LEAP = 1
ELSE IF (DAYS.GT.364) THEN
YEAR = YEAR+1859
DAYS = DAYS-365
ELSE
YEAR = YEAR+1858
ENDIF
IDAYS = DAYS+1
IF (LEAP+152.GT.IDAYS) THEN
IF (LEAP+60.GT.IDAYS) THEN
IF (32.GT.IDAYS) THEN
MONTH = 'JAN'
IDAY = IDAYS
ELSE
MONTH = 'FEB'
IDAY = IDAYS-31
ENDIF
ELSE IF (LEAP+91.GT.IDAYS) THEN
MONTH = 'MAR'
IDAY = IDAYS-(59+LEAP)
ELSE IF (LEAP+121.GT.IDAYS) THEN
MONTH = 'APR'
IDAY = IDAYS-(90+LEAP)
ELSE
MONTH = 'MAY'
IDAY = IDAYS-(120+LEAP)
ENDIF
ELSE
IF (LEAP+244.GT.IDAYS) THEN
IF (LEAP+182.GT.IDAYS) THEN
MONTH = 'JUN'
IDAY = IDAYS-(151+LEAP)
ELSE IF (LEAP+213.GT.IDAYS) THEN
MONTH = 'JUL'
IDAY = IDAYS-(181+LEAP)
ELSE
MONTH = 'AUG'
IDAY = IDAYS-(212+LEAP)
ENDIF
ELSE IF (LEAP+305.GT.IDAYS) THEN
IF (LEAP+274.GT.IDAYS) THEN
MONTH = 'SEP'
IDAY = IDAYS-(243+LEAP)
ELSE
MONTH = 'OCT'
IDAY = IDAYS-(273+LEAP)
ENDIF
ELSE IF (LEAP+335.GT.IDAYS) THEN
MONTH = 'NOV'
IDAY = IDAYS-(304+LEAP)
ELSE
MONTH = 'DEC'
IDAY = IDAYS-(334+LEAP)
ENDIF
ENDIF
SECS = (FRAC*27*25)/(2**11)
HOUR = IFIX(SECS)/(60*60)
MIN = MOD(IFIX(SECS)/60,60)
ISECS = MOD(IFIX(SECS),60)
WRITE(DATEC,10) IDAY,MONTH,YEAR,HOUR,MIN,ISECS
10 FORMAT(I2,'-',A3,'-',I4,' ',I2.2,':',I2.2,':',I2.2)
DO I=1,20,1
LINE(LINEL+I-1) = CDATE(I)
ENDDO
LINEL = LINEL+20
RETURN
END
INTEGER*4 FUNCTION EOT_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the EOT command action routine. It is called when
C the user wants to move the magtape to the end of tape.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
INTEGER*2 IOSB(4)
INTEGER*4 STATUS
EXTERNAL IO$_SKIPFILE,SS$_VOLINV
EXTERNAL DUMPER_NTDSEL
INTEGER*4 SYS$QIOW
LOGICAL FLAG
C
IF (.NOT.GOTDEV) THEN
CALL ERRORM(%LOC(DUMPER_NTDSEL))
EOT_COMMAND = 1
RETURN
ENDIF
C
FLAG = .TRUE.
DO WHILE (FLAG)
CALL MTSKPF(CHANNEL,10000,STATUS)
IF (.NOT.STATUS) FLAG = .FALSE.
IF (STATUS.EQ.%LOC(SS$_VOLINV)) THEN
WRITE(*,20) DEVNAME(1:DEVLEN)
20 FORMAT(' The magtape must be mounted before this program can',/,
1 ' access it. Exit and type "$ MOUNT/FOR ',A,'" before',/,
2 ' trying again.')
ENDIF
ENDDO
EOT_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION GO_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the GO command action routine. It is called when
C the save set is to be processed. The value of GOVALUE is
C the number of save sets to process. Default value is one.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL SS$_ENDOFFILE,SS$_ENDOFVOLUME
EXTERNAL DUMPER_STDBLK,DUMPER_CCCBLK
EXTERNAL DUMPER_NTDSEL,DUMPER_UNKBLK
C
C Local data storage:
C BUFFER -- The input buffer from the magtape
C BUFLEN -- The buffer length (a constant)
C ACTLEN -- The actual number of bytes read in by a read
C STATUS -- The status of the I/O transfer
C HEADER -- The reformatted DEC-10/20 information
C
INTEGER*4 BUFLEN
PARAMETER (BUFLEN=2720)
BYTE BUFFER(BUFLEN)
INTEGER*4 ACTLEN,STATUS
INTEGER*4 HEADER(2,32)
C
IF (.NOT.GOTDEV) THEN
CALL ERRORM(%LOC(DUMPER_NTDSEL))
GO_COMMAND = 1
RETURN
ENDIF
C
C Initialize the validation tables
C
DO I=1,RESMAX
VALIDD(I) = .FALSE.
VALIDF(I) = .FALSE.
ENDDO
CDIRLEN = 0
C
DO WHILE (GOVALUE.GT.0)
CALL MTREAD(CHANNEL,BUFFER,BUFLEN,ACTLEN,STATUS)
IF (.NOT.STATUS) THEN
IF (STATUS.EQ.%LOC(SS$_ENDOFFILE)) THEN
IF (EOFSEEN) THEN
CALL ERRORM(%LOC(SS$_ENDOFVOLUME))
GOVALUE = 0
ELSE
GOVALUE = GOVALUE-1
EOFSEEN = .TRUE.
ENDIF
ELSE
GOVALUE = 0
ENDIF
ELSE
EOFSEEN = .FALSE.
IF (ACTLEN.EQ.2720) THEN
IF (BLKTYP.NE.STDBLK) THEN
CALL ERRORM(%LOC(DUMPER_STDBLK))
BLKTYP = STDBLK
ENDIF
CALL CVT36(BUFFER,HEADER,32)
CALL PROCESS(BUFFER,HEADER)
ELSE IF (ACTLEN.EQ.2448) THEN
IF (BLKTYP.NE.CCCBLK) THEN
CALL ERRORM(%LOC(DUMPER_CCCBLK))
BLKTYP = CCCBLK
ENDIF
CALL CVT72(BUFFER,HEADER,32)
CALL PROCESS(BUFFER,HEADER)
ELSE
CALL ERRORM(%LOC(DUMPER_UNKBLK),ACTLEN)
CALL MTSKPF(CHANNEL,1,STATUS)
GOVALUE = GOVALUE-1
EOFSEEN = .TRUE.
ENDIF
ENDIF
ENDDO
GO_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION HELP_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the HELP command action routine. It is called when
C the user wants to get HELP.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
CHARACTER*1 ANS
C
WRITE(*,10)
10 FORMAT(
1 1X,'Magtape Handling Commands:',/,
1 7X,'USE drive -- Use the magtape drive "drive"',/,
1 7X,'EOT -- Skip to the end of tape',/,
1 7X,'REWIND -- Rewind the magtape',/,
1 7X,'SKIP n -- Skip ''n'' save sets (negative means reverse)',/,
2 1X,'File Processing Commands:',/,
2 7X,'GO n -- Process ''n'' save sets',/,
2 7X,'RESET -- Reset the list of RESTORE commands',/,
2 7X,'RESTORE vaxdir=files -- Restore the files on tape to the',/,
2 7X,'VAX directory specified (may be repeated)',/,
2 7X,'WHAT -- Lists the RESTORE commands that are active',/,
2 7X,'Type Control-C to abort the processing of a GO command',/,
2 1X,'Type RETURN to get the remainder of the HELP')
READ(*,15) ANS
15 FORMAT(A)
WRITE(*,20)
20 FORMAT(
3 1X,'File Listing Commands:',/,
3 7X,'FILES -- The files restored will be listed on the user''s',
3 ' terminal',/,
3 7X,'LIST -- Allows the user to select a tape directory listing',/,
3 7X,'SILENT -- Reverses the action of the FILES command',/,
4 1X,'Mode Selection Commands:',/,
4 7X,'ASCII -- Convert files to VAX ASCII format',/,
4 7X,'BINARY -- Convert files to VAX BINARY format',/,
4 7X,'NONE -- Set output record attribute to NONE',/,
4 7X,'CR -- Set output record attribute to Carriage Return',/,
4 7X,'FORTRAN -- Set output record attribute to FORTRAN mode',/,
5 1X,'Miscellaneous Commands:',/,
5 7X,'HELP -- Print this message',/,
5 7X,'STOP, EXIT, or QUIT -- Leave the program',/,
5 1X,'All commands may be typed in lower or upper case',
5 ' letters and',/,1x,'may be abbreviated to the minimum',
5 ' unique number of letters.',/,1x,'For example: REST',
5 ' can abbreviate RESTORE.')
HELP_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION REW_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the REWIND command action routine. It is called
C when the user wants to rewind the magtape back to the
C start of the tape.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INTEGER*4 SYS$QIOW
INTEGER*4 STATUS
INTEGER*2 IOSB(4)
EXTERNAL IO$_REWIND
EXTERNAL DUMPER_NTDSEL
INCLUDE 'DMPCOM.FOR/NOLIST'
C
IF (.NOT.GOTDEV) THEN
CALL ERRORM(%LOC(DUMPER_NTDSEL))
EOT_COMMAND = 1
RETURN
ENDIF
C
STATUS = SYS$QIOW(,%VAL(CHANNEL),IO$_REWIND,IOSB,,
1 ,,,,,,)
IF (.NOT.STATUS) CALL ERRORM(STATUS)
REW_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION SKIP_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the SKIP command action routine. It is called when
C the user wants to skip forward or backward save sets.
C If the skip value supplied is negative, the program will
C skip back save sets. If positive, the program will skip
C forward save sets.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
INTEGER*2 IOSB(4)
INTEGER*4 STATUS
EXTERNAL IO$_SKIPFILE,SS$_VOLINV
EXTERNAL DUMPER_NTDSEL
LOGICAL FLAG
INTEGER*4 SKIPIT,COUNT
C
IF (.NOT.GOTDEV) THEN
CALL ERRORM(%LOC(DUMPER_NTDSEL))
SKIP_COMMAND = 1
RETURN
ENDIF
C
C Skip in the direction desired... subtract one from
C 0 and less skips.
C
IF (SIGN.EQ.ICHAR('-')) THEN
COUNT = -SKIPNO
ELSE
COUNT = SKIPNO
ENDIF
CALL MTSKPF(CHANNEL,COUNT,STATUS)
IF (STATUS.EQ.%LOC(SS$_VOLINV)) THEN
WRITE(*,20) DEVNAME(1:DEVLEN)
20 FORMAT(' The magtape must be mounted before this program can',/,
1 ' access it. Stop and type "$ MOUNT/FOR ',A,'" before',/,
2 ' trying again.')
ENDIF
C
SKIP_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION USE_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the USE command action routine. It is called when
C the device is to be selected. The common variable DEVNAME
C has the characters in the name, and the common variable
C DEVLEN is the number of characters in that name. The
C channel assignment made by SYS$ASSIGN will be put into
C the common variable CHANNEL.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
INTEGER*4 SYS$ASSIGN,SYS$DASSGN
INTEGER*4 STATUS
EXTERNAL DUMPER_ERRDPD,DUMPER_ERRATD
C
IF (GOTDEV) THEN
STATUS = SYS$DASSGN(%VAL(CHANNEL))
IF (.NOT.STATUS) THEN
CALL ERRORM(%LOC(DUMPER_ERRDPD))
CALL ERRORM(STATUS)
ENDIF
ENDIF
C
STATUS = SYS$ASSIGN(DEVNAME(1:DEVLEN),CHANNEL,,)
IF (.NOT.STATUS) THEN
CALL ERRORM(%LOC(DUMPER_ERRATD),DEVNAME(1:DEVLEN))
CALL ERRORM(STATUS)
GOTDEV = .FALSE.
ELSE
GOTDEV = .TRUE.
ENDIF
USE_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION USE_NAME(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the GO command action routine. It is called when
C when the device name has been entered. The name is copied
C from TOKEN into DEVNAME, and TLEN is copied into DEVLEN.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INTEGER*4 I
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
DEVLEN = MIN(64,%LOC(TLEN))
DO I=1,DEVLEN,1
DEVNAME(I:I) = CHAR(TOKEN(I))
ENDDO
C
USE_NAME = 1
RETURN
END
C Start of include file DMPCOM.FOR
C
C Common block for DUMPER program
C
C DMPCOM holds the integer and logical common variables
C SIGN -- Sign of value (if any)
C SKIPNO -- Number of save sets to skip
C DONE -- If .TRUE., leave the program
C GOVALUE -- Number of save sets to process
C CHANNEL -- Channel number of the magtape
C DEVLEN -- Length of the device name
C GOTDEV -- If .TRUE., a device has been assigned
C BLKTYP -- The type of data block on the tape. It can have
C the values NONE, STDBLK, and CCCBLK for undefined, standard,
C and CCC stupid TU70 format.
C EOFSEEN -- Flag indicating if the previous operation
C caused the end of file to be found
C FILEOK -- Flag indicating if an output file is open
C and that the data is to be copied to the output file.
C IOMODE -- This indicates the type of input conversion
C that is to be done. If equal to BINARY, the data is
C copied to the output without conversion into 5 bytes
C per DEC 10/20 word. If equal to ASCII, the data is
C copied to the output with 7 bit bytes converted to
C 8 bit bytes.
C PRMODE -- Printing mode flag. If equal to SILENT, then
C no file names are echoed on the terminal. If equal to
C FILES, then the file names are printed on the terminal
C as they are copied.
C ORMODE -- Output Record Mode. If equal to NONE, then
C no carriage control attributes are set on the output
C file. If equal to CR, then the Carriage Return attribute
C is set for the output file. If equal to FORTRAN, then
C the FORTRAN attribute is set for the output file.
C LIST -- Listing flag. If .TRUE., then a file is opened
C on channel 2 to recieve the listing of the file data.
C
INTEGER*4 SIGN,SKIPNO
LOGICAL*4 DONE,GOTDEV
INTEGER*4 GOVALUE,CHANNEL
INTEGER*2 BLKTYP,NONE,STDBLK,CCCBLK
PARAMETER (NONE=0,STDBLK=1,CCCBLK=2)
LOGICAL*4 EOFSEEN
LOGICAL*4 FILEOK
INTEGER*2 IOMODE,BINARY,ASCII
PARAMETER (ASCII=0,BINARY=1)
INTEGER*2 PRMODE,SILENT,FILES
PARAMETER (SILENT=0,FILES=1)
INTEGER*2 ORMODE,CR,FORTRAN
PARAMETER (CR=1,FORTRAN=2)
LOGICAL*4 LIST
C
COMMON /DMPCOM/SIGN,SKIPNO,DONE,GOVALUE,CHANNEL,
1 DEVLEN,GOTDEV,BLKTYP,EOFSEEN,FILEOK,IOMODE,
2 PRMODE,ORMODE,LIST
C
C DMPCHR common holds the character variables for dumper
C DEVNAME -- Name of the magtape device
C
CHARACTER*64 DEVNAME
COMMON /DMPCHR/DEVNAME
C
C End of include file DMPCOM.FOR
C BEGIN OF DMPHEAD.FOR INCLUDE FILE
C CONTAINS EQUIVALENCES USED FOR DUMPER/BACKUP FORMAT HEADERS
C
C FOR ALL HEADER BLOCKS:
C G$TYPE -- THE TYPE OF HEADER
C 1=LABEL RECORD, 2=START OF SAVE SET, 3=END OF SAVE SET,
C 4=FILE RECORD, 5=UFD RECORD, 6=END OF VOLUME, 7=COMMENT
C G$SEQ -- A SEQUENCE NUMBER UNIQUE FOR THAT RECORD.
C THIS NUMBER IS INCREMENTED FOR EACH RECORD WRITTEN.
C G$RTNM -- THE RELATIVE TAPE NUMBER FOR THIS TAPE
C WITHIN A SAVE SET.
C G$FLAG -- VARIOUS BITS THAT DEPEND UPON THE TYPE OF
C RECORD INVOLVED. CURRENTLY, FOR ALL BUT DATA RECORDS,
C THIS WORD IS ZERO. FOR FILE DATA RECORDS, THE FOLLOWING
C ASSIGNMENTS HAVE BEEN MADE.
C GF$EOF -- (DEC-10 BIT 0) THE FLAG SET IF THIS IS THE
C LAST TAPE BLOCK FOR THIS DISK FILE. BOTH THIS AND
C GF$SOF CAN BE SET FOR SHORT ONE BLOCK FILES.
C GF$RPT -- (DEC-10 BIT 1) THIS FLAG IS SET IF THIS
C BLOCK REPEATS THE PREVIOUS ONE. THIS IS USED IF A
C TAPE ERROR OCCURRED FOR THE PREVIOUS RECORD.
C GF$NCH -- (DEC-10 BIT 2) THIS IS SET IF A CHECKSUM
C FOR THE BLOCK HAS NOT BEEN COMPUTED.
C GF$SOF -- (DEC-10 BIT 3) THIS IS SET IF THIS IS THE
C FIRST TAPE BLOCK FOR A FILE.
C G$CHK -- CONTAINS THE CHECKSUM FOR THE TAPE RECORD
C UNLESS GF$NCH IS SET.
C G$SIZ -- THE NUMBER OF FILE DATA WORDS IN THIS BLOCK.
C G$LND -- THE NUMBER OF WORDS TO SKIP BEFORE FILE DATA
C BEGINS.
C
INTEGER G$TYPE,G$SEQ,G$RTNM,G$FLAG,G$CHK,G$SIZ,G$LND
PARAMETER (G$TYPE=1,G$SEQ=2,G$RTNM=3,G$FLAG=4,G$CHK=5,
1 G$SIZ=6,G$LND=7)
INTEGER GF$EOF,GF$RPT,GF$NCH,GF$SOF
PARAMETER (GF$EOF=8,GF$RPT=4,GF$NCH=2,GF$SOF=1)
C
C IN LABEL RECORDS (G$TYPE WORD IS 1):
C L$RLNM -- SIXBIT WORD CONTAINING THE REEL NAME
C L$DATE -- DATE/TIME OF THE LABELLING IN DEC-10
C UNIVERSAL FORMAT (LEFT HALF IS NUMBER OF DAYS
C SINCE 17-NOV-1859, AND RIGHT HALF IS FRACTIONS
C OF A DAY)
C L$DSTR -- DATE/TIME BEFORE WHICH THE TAPE CANNOT BE
C SCRATCHED. BEFORE THIS TIME, ONLY APPENDS CAN BE DONE
C L$DEV -- SIXBIT WORD DEFINING THE PHYSICAL DEVICE
C NAME OF THE MAGTAPE DRIVE USED TO WRITE THE LABEL
C L$FMT -- A NUMBER INDICATING THE BACKUP FORMAT
C L$BVER -- THE BACKUP VERSION USED TO WRITE THE LABEL
C
INTEGER L$RLNM,L$DATE,L$DSTR,L$DEV,L$FMT,L$BVER
PARAMETER (L$RLNM=13,L$DATE=14,L$DSTR=15,L$DEV=16,L$FMT=17,
1 L$BVER=18)
C
C FOR START AND END OF SAVE SET RECORDS:
C S$SVER -- SYSTEM VERSION NUMBER
C S$FMT -- BACKUP FORMAT NUMBER
C S$BVER -- BACKUP VERSION NUMBER
C S$DATE -- DATE/TIME OF WRITING THE DATA IN UNIVERSAL
C TIME FORMAT (SEE L$DATE DESCRIPTION)
C S$DEV -- PHYSICAL DEVICE NAME OF THE MAGTAPE DRIVE
C USED TO WRITE THE DATA (IN SIXBIT)
C S$APR -- THE SERIAL NUMBER OF THE CPU WRITING THE DATA
C
INTEGER S$SVER,S$FMT,S$BVER,S$DATE,S$DEV,S$APR
PARAMETER (S$SVER=17,S$FMT=14,S$BVER=15,S$DATE=13,S$DEV=19,
1 S$APR=18)
C
C FOR UFD RECORDS:
C D$STR -- SIXBIT WORD CONTAINING THE STRUCTURE NAME
C D$LVL -- NUMBER FOR THE NESTING LEVEL OF THE
C DIRECTORY. 0=UFD, 1-5=SFD LEVEL
C D$PCHK -- CHECKSUM OF THE O$NAME FULL PATH NAME BLOCK
C
INTEGER D$STR,D$LVL,D$PCHK
PARAMETER (D$STR=13,D$LVL=14,D$PCHK=15)
C
C FOR FILE DATA RECORDS:
C F$PCHK -- CHECKSUM OF THE FULL PATHNAME BLOCK (O$NAME)
C F$RDW -- RELATIVE DATA WORD OF THE FIRST WORD ON TAPE
C FOR THE FILE
C F$PTH -- A TWELVE WORD BLOCK USED TO STORE INFORMATION
C SUITABLE TO RESTORE THE FILE. IT HOLDS ENOUGH ROOM FOR
C A TOPS-10 FILE IN A UFD OF UP TO 5 CHARACTERS EACH IN
C THE PPN. STORED AS 7 BIT BYTES AS: DATA TYPE, LENGTH IN
C WORDS, ASCII DATA. DATA TYPES ARE: 1=DEVICE, 2=FILENAME,
C 3=EXTENSION, 32+N=NTH DIRECTORY ENTRY.
C
INTEGER F$PCHK,F$RDW,F$PTH
PARAMETER (F$PCHK=13,F$RDW=14,F$PTH=15)
C
C END OF DMPHEAD.FOR INCLUDE FILE
.TITLE DMPMESS DUMPER error and information messages
.FACILITY DUMPER,2049
.SEVERITY INFORMATIONAL
STDBLK <Using standard BACKUP block size>
CCCBLK <Using CCC TU70 BACKUP block size>
NTDSEL <No tape drive has been selected by the USE command>
UNKBLK/FAO=1 <Unknown block length !UL, skipping this save set>
ERRDPD <Error deassigning previous tape drive>
ERRATD/FAO=1 <Error assigning tape drive !AS>
RESMAX <Maximum number of restore commands reached>
RESIGN <Program limit exceeded, restore command ignored>
RESSFD <Tape name has too many SFD's>
RESDNM <Directory name is too long>
RESFNM <File name is too long>
ABLIST <Error in filename, listing disabled>
NOLIST <No listing will be generated>
IDFE/FAO=1 <Internal dumper filespec error !/with !AS>
NOCTLC <No Control-C interrupt handler created>
ABORT <Processing aborted by user, to restart type GO>
.END
C START OF DMPREC.FOR INCLUDE FILE
C
C THIS CONTAINS PARAMETERS FOR DUMPER/BACKUP OVERHEAD
C REGIONS CONTAINED IN THE DATA PORTION OF RECORDS.
C THESE REGIONS ARE PRECEEDED BY A WORD CONTAINING
C A CONTROL WORD OF THE FORM:
C LEFT HALF = TYPE OF REGION
C RIGHT HALF = LENGTH OF REGION IN WORDS INCLUDING THIS WORD
C ALLOWABLE TYPES ARE:
C O$NAME -- TO GIVE THE FULL PATH IDENTIFICATION OF THE FILE
C WITHOUT PUNCTUATION. IT CONSISTS OF SEVERAL SUB-BLOCKS
C THAT ARE DESCRIBED BELOW.
C O$FILE -- A BLOCK CONTAINING THE FILE ATTRIBUTES. IT HAS
C A FIXED FORMAT THAT IS DESCRIBED BELOW.
C O$DIRT -- RESERVED FOR DIRECTORY ATTRIBUTES
C O$SYSN -- THE SYSTEM HEADER LINE IN ASCII FOLLOWED BY A
C ZERO BYTE.
C O$SSNM -- THE SAVE SET NAME IN ASCII FOLLOWED BY A ZERO BYTE.
C
INTEGER O$FILE,O$DIRT,O$SYSN,O$SSNM
PARAMETER (O$NAME=1,O$FILE=2,O$DIRT=3,O$SYSN=4,O$SSNM=5)
C
C IN A O$NAME REGION:
C THE SUB-BLOCKS ARE IN STANDARD ORDER; DEVICE, DIRECTORIES
C (TOP DOWN), FILE NAME, EXTENSION, VERSION, AND GENERATION.
C MISSING SUB-BLOCKS CORRESPOND TO PORTIONS OF THE PATH
C SPECIFICATION THAT ARE OMITTED. EACH SUB-BLOCK IS OF THE
C FORM:
C LEFT HALF -- TYPE OF SUB-BLOCK
C RIGHT HALF -- LENGTH OF SUB-BLOCK IN WORDS INCLUDING THIS ONE
C THE REST OF EACH SUB-BLOCK IS AN ASCIZ (TRAILING ZERO BYTE)
C STRING WITH NO LEADING OR IMBEDDED ZERO BYTES.
C N$DEV -- DEVICE NAME
C N$NAME -- FILE NAME
C N$EXT -- EXTENSION
C N$VER -- VERSION
C N$GEN -- GENERATION
C N$UFD -- USER FILE DIRECTORY
C N$SFD1 -- SUB-FILE DIRECTORY (LEVEL 1)
C N$SFD2 THROUGH 5 ARE OTHER SFD'S (LEVEL 2 THROUGH 5)
C
INTEGER N$DEV,N$NAME,N$EXT,N$VER,N$GEN,N$UFD,N$SFD1,
1 N$SFD2,N$SFD3,N$SFD4,N$SFD5
PARAMETER (N$DEV=1,N$NAME=2,N$EXT=3,N$VER=4,N$GEN=5,
1 N$UFD=32,N$SFD1=33,N$SFD2=34,N$SFD3=35,N$SFD4=36,N$SFD5=37)
C
C FOR FILE ATTRIBUTE BLOCKS:
C THIS IS A FIXED REGION WITH THE FOLLOWING OFFSETS:
C A$FHLN -- LENGTH IN WORDS OF THE HEADER
C A$FLGS -- RESERVED FOR FLAGS
C A$WRIT -- DATE/TIME OF LAST WRITE
C A$ALLS -- ALLOCATED SIZE IN WORDS
C A$MODE -- MODE OF LAST WRITE
C A$LENG -- LENGTH IN BYTES
C A$BSIZ -- BYTE SIZE (7 OR 36)
C A$VERS -- VERSION ID (.JBVER FORMAT)
C THE DATE/TIME ENTRY IS IN DEC-10 UNIVERSAL FORMAT WITH
C THE LEFT HALF BEING THE NUMBER OF DAYS SINCE NOV. 17, 1858,
C AND THE RIGHT HALF BEING THE FRACTION OF THE DAY.
C
INTEGER A$FHLN,A$FLGS,A$WRIT,A$ALLS,A$MODE,A$LENG,A$BSIZ,A$VERS
PARAMETER (A$FHLN=1,A$FLGS=2,A$WRIT=3,A$ALLS=4,A$MODE=5,
1 A$LENG=6,A$BSIZ=7,A$VERS=8)
C
C END OF DMPREC.FOR INCLUDE FILE
C Start of include file DMPRES.FOR
C
C Common block for DUMPER program RESTORE command
C
C RESMAX -- Number of restore commands allowed
C TAPEMAX -- Number of filespec parts on the tape
C RESCNT -- Current index into restore tables
C VAXDIR -- Directories to restore to
C VAXLEN -- Length of VAXDIR entry
C TAPENAME -- DEC 10/20 filespec parts in order
C (1=UFD, 2 to TAPEMAX-2=SFD, TAPEMAX-1=FILE,TAPEMAX=EXT)
C TAPELEN -- Length of corresponding TAPENAME entry
C VALIDF -- Valid file table. If .TRUE., then the
C corresponding name is still valid (so far).
C VALIDD -- Valid directory table. If .TRUE., then
C the corresponding directory name is still ok.
C NVDIR -- If .TRUE., then no directories are valid.
C CURDIR -- Current directory name.
C CDIRLEN -- Length of current directory name (0 if none).
C STNAME -- Selected tape name
C STEXT -- Selected extension
C STNLEN -- Selected Name Length
C STELEN -- Selected Extension Length
C
INTEGER*4 RESMAX,TAPEMAX,RESCNT,VAXLEN,TAPELEN,TAPECNT
LOGICAL VALIDF,VALIDD,NVDIR
INTEGER*4 CDIRLEN,STNLEN,STELEN
PARAMETER (RESMAX=100,TAPEMAX=8)
DIMENSION VAXLEN(RESMAX),TAPELEN(TAPEMAX,RESMAX)
DIMENSION VALIDF(RESMAX),VALIDD(RESMAX)
COMMON /RESCOM/ RESCNT,TAPECNT,VAXLEN,TAPELEN
1 ,VALIDF,VALIDD,CDIRLEN,NVDIR,STNLEN,STELEN
C
CHARACTER*64 VAXDIR(RESMAX)
CHARACTER*32 TAPENAME(TAPEMAX,RESMAX)
CHARACTER*256 CURDIR
CHARACTER*9 STNAME
CHARACTER*3 STEXT
COMMON /RESCOMC/ VAXDIR,TAPENAME,CURDIR,STNAME,STEXT
C
C End of include file DMPCOM.FOR
.TITLE DMPSTATE DUMPER PROGRAM STATE TABLES
.LIBRARY 'DUMPER'
;+
; This segment defines the tables required for the
; LIB$TPARSE finite state parser. The global variables
; are:
; DMPINIT -- The initial state of the parser tables
; DMPKEY -- The keyword list of the parser tables
; VDINIT -- The initial state of directory tables
; VDKEY -- The keyword list of the directory tables
; VFINIT -- The initial state of file tables
; VFKEY -- The keyword list of the file tables
;-
DMPCOM
DMPCHR
;Comma definition...since I had problems with ','
COMMA = 44
;
$INIT_STATE DMPINIT,DMPKEY
;
$STATE
$TRAN 'QUIT',STOP
$TRAN 'EXIT',STOP
$TRAN 'STOP',STOP
$TRAN 'REWIND',REWIND
$TRAN 'EOT',EOT
$TRAN 'SKIP',SKIP
$TRAN 'GO',GO
$TRAN 'HELP',HELP
$TRAN 'USE',USE
$TRAN 'RESTORE',RESTORE
$TRAN 'RESET',RESET
$TRAN 'WHAT',WHAT
$TRAN 'ASCII',ASCII
$TRAN 'BINARY',BINARY
$TRAN 'SILENT',SILENT
$TRAN 'FILES',FILES
$TRAN 'LISTING',LISTING
$TRAN 'NONE',NONE
$TRAN 'CR',CR
$TRAN 'FORTRAN',FORTRAN
$TRAN TPA$_EOS,TPA$_EXIT
;+
; STOP COMMAND
;-
$STATE STOP
$TRAN TPA$_EOS,TPA$_EXIT,,1,DONE
;+
; REWIND COMMAND
;-
$STATE REWIND
$TRAN TPA$_EOS,TPA$_EXIT,REW_COMMAND
;+
; EOT COMMAND
;-
$STATE EOT
$TRAN TPA$_EOS,TPA$_EXIT,EOT_COMMAND
;+
; SKIP COMMAND
;-
$STATE SKIP
$TRAN TPA$_DECIMAL,SKIP_END,,,SKIPNO
$TRAN '-',,,,SIGN
;
$STATE
$TRAN TPA$_DECIMAL,,,,SKIPNO
;
$STATE SKIP_END
$TRAN TPA$_EOS,TPA$_EXIT,SKIP_COMMAND
;+
; GO COMMAND
;-
$STATE GO
$TRAN TPA$_DECIMAL,,,,GOVALUE
$TRAN TPA$_LAMBDA,,,1,GOVALUE
;
$STATE
$TRAN TPA$_EOS,TPA$_EXIT,GO_COMMAND
;+
; HELP COMMAND
;-
$STATE HELP
$TRAN TPA$_EOS,TPA$_EXIT,HELP_COMMAND
;+
; USE Command
;-
$STATE USE
$TRAN TPA$_STRING,,USE_NAME
;
$STATE
$TRAN ':'
$TRAN TPA$_EOS,TPA$_EXIT,USE_COMMAND
;
$STATE
$TRAN TPA$_EOS,TPA$_EXIT,USE_COMMAND
;+
; RESTORE Command
;-
$STATE RESTORE
$TRAN '[',,RES_VDIR
;VAX directory parsing
$STATE
$TRAN '-',VMIN,RES_VMIN
$TRAN TPA$_SYMBOL,,RES_VNAME
$TRAN TPA$_LAMBDA
;
$STATE VDOT
$TRAN '.',,RES_VDOT
$TRAN ']',VEQ
;
$STATE
$TRAN TPA$_SYMBOL,VDOT,RES_VNAME
;
$STATE VMIN
$TRAN '-',VMIN,RES_VMIN
$TRAN TPA$_LAMBDA,VDOT
;
;End of VAX directory, start of 10/20 directory
$STATE VEQ
$TRAN '='
;
$STATE
$TRAN '['
;UFD/SFD processing
$STATE TNAM
$TRAN TPA$_SYMBOL,,RES_TNAME
$TRAN '*',,RES_TSTAR
;
$STATE
$TRAN COMMA,TNAM,RES_TDOT
$TRAN '.',TNAM,RES_TDOT
$TRAN ']',,RES_TBR
;File name
$STATE
$TRAN TPA$_SYMBOL,,RES_TNAME
$TRAN '*',,RES_TSTAR
$TRAN '.',EXT,RES_TDOT
;
$STATE
$TRAN '.',,RES_TDOT
$TRAN TPA$_EOS,TPA$_EXIT,RES_COMMAND
;Extension
$STATE EXT
$TRAN TPA$_SYMBOL,,RES_TNAME
$TRAN '*',,RES_TSTAR
$TRAN TPA$_EOS,TPA$_EXIT,RES_COMMAND
;
$STATE
$TRAN TPA$_EOS,TPA$_EXIT,RES_COMMAND
;+
; RESET Command -- Reset the restore tables
;-
$STATE RESET
$TRAN TPA$_EOS,TPA$_EXIT,RESET_COMMAND
;+
; WHAT Command -- Print the restore information
;-
$STATE WHAT
$TRAN TPA$_EOS,TPA$_EXIT,WHAT_COMMAND
;+
; ASCII Command -- normal text mode
;-
$STATE ASCII
$TRAN TPA$_EOS,TPA$_EXIT,SET_ASCII
;+
; BINARY Command -- read binary files from the tape
;-
$STATE BINARY
$TRAN TPA$_EOS,TPA$_EXIT,SET_BINARY
;+
; SILENT Command -- do not print any messages
;-
$STATE SILENT
$TRAN TPA$_EOS,TPA$_EXIT,SET_SILENT
;+
; FILES Command -- print out the names of files processed
;-
$STATE FILES
$TRAN TPA$_EOS,TPA$_EXIT,SET_FILES
;+
; LISTING Command -- generate a listing of all files on the tape
;-
$STATE LISTING
$TRAN TPA$_EOS,TPA$_EXIT,SET_LIST
;+
; NONE Command -- no carriage control files
;-
$STATE NONE
$TRAN TPA$_EOS,TPA$_EXIT,SET_NONE
;+
; CR Command -- carriage control files
;-
$STATE CR
$TRAN TPA$_EOS,TPA$_EXIT,SET_CR
;+
; FORTRAN Command -- FORTRAN format files
;-
$STATE FORTRAN
$TRAN TPA$_EOS,TPA$_EXIT,SET_FORT
;
$END_STATE
.PAGE
;+
; Restore processing state tables
;-
$INIT_STATE VDINIT,VDKEY
;
$STATE
$TRAN TPA$_SYMBOL
$TRAN '[',UFD
;
$STATE
$TRAN ':'
;
$STATE UFD
$TRAN TPA$_SYMBOL,,VAL_DIR
;
$STATE
$TRAN ']',TPA$_EXIT
$TRAN '.',UFD
;
$END_STATE
;
$INIT_STATE VFINIT,VFKEY
;
$STATE
$TRAN TPA$_SYMBOL,,VAL_NAME
;
$STATE
$TRAN '.'
;
$STATE
$TRAN TPA$_SYMBOL,,VAL_EXT
$TRAN TPA$_LAMBDA
;
$STATE
$TRAN TPA$_LAMBDA,TPA$_EXIT,VAL_OPEN
;
$END_STATE
;
.END
PROGRAM DUMPER
C
C A program to read files from a DEC-10 BACKUP format
C magtape or from a DEC-20 DUMPER format magtape.
C
C COMLINE -- Command line from user
C COMLEN -- Length of command line
C STATUS -- Status code from I/O routines
C
IMPLICIT COMPLEX (A-Z)
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
CHARACTER*255 COMLINE
INTEGER*2 COMLEN
INTEGER*4 STATUS
C
C External addresses that are needed
C
EXTERNAL DMPINIT,DMPKEY
C
C Goodies for Control-C interrupt handling
C
INTEGER*4 SYS$ASSIGN,SYS$QIOW,SYS$DASSGN
EXTERNAL IO$_SETMODE,IO$M_CTRLCAST
EXTERNAL DUMPER_NOCTLC,DUMPER_ABORT,INTHAND
INTEGER*4 IOFUNC
C
C Init for Control-C Interrupt handling
C
STATUS = SYS$ASSIGN('TT',TERCHAN,,)
IF (.NOT.STATUS) THEN
CALL ERRORM(%LOC(DUMPER_NOCTLC))
ABFLAG = .FALSE.
ELSE
ABFLAG = .TRUE.
ENDIF
IOFUNC = %LOC(IO$_SETMODE)+%LOC(IO$M_CTRLCAST)
C
C Now enter the main loop. Essentially, it inputs
C a command line, dispatches to the appropriate
C part of the program that handles the action desired.
C
DONE = .FALSE.
BLKTYP = NONE
EOFSEEN = .TRUE.
DO WHILE (.NOT.DONE)
IF (ABFLAG) THEN
STATUS = SYS$QIOW(,%VAL(TERCHAN),%VAL(IOFUNC),,,,
1 INTHAND,,,,,)
IF (.NOT.STATUS) THEN
CALL ERRORM(%LOC(DUMPER_NOCTLC))
CALL ERRORM(STATUS)
ENDIF
ABFLAG = .FALSE.
ENDIF
SIGN = 0
GOVALUE = 0
CALL LIB$GET_INPUT(COMLINE,'Command: ',COMLEN)
CALL STR$UPCASE(COMLINE(1:COMLEN),COMLINE(1:COMLEN))
CALL COMMAND(COMLINE(1:COMLEN),DMPINIT,DMPKEY,STATUS)
IF (.NOT.STATUS) WRITE(*,110)
110 FORMAT(' For help, type HELP')
IF (ABFLAG) CALL ERRORM(%LOC(DUMPER_ABORT))
ENDDO
END
SUBROUTINE INTHAND
C
C This will set the flags so that the DUMPER program will come
C to a stop (a restartable one, by the way...). Normally called
C as a result of the user typing Control-C.
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
GOVALUE = 0
ABFLAG = .TRUE.
RETURN
END
BLOCK DATA
C
C Common block initialization for DUMPER
C
INCLUDE 'DMPCOM.FOR'
DATA SIGN,SKIPNO,DONE,GOVALUE,CHANNEL,DEVLEN,GOTDEV
1 /0,0,.FALSE.,0,0,0,.FALSE./
DATA EOFSEEN,FILEOK,IOMODE/.FALSE.,.FALSE.,ASCII/
DATA DEVNAME/' '/
INCLUDE 'DMPRES.FOR'
DATA RESCNT/1/
END
PROGRAM DUMPERDIR
C
C THIS PROGRAM TAKES DUMPER/BACKUP SAVE SETS AND
C PRODUCES A LISTING OF THE FILES AND THEIR ATTRIBUTES
C FOR THE USER.
C
CHARACTER*2720 JUNK
BYTE JHEAD(160),JDATA(2560)
EQUIVALENCE (JUNK,JHEAD),(JUNK(161:161),JDATA)
C
INTEGER*4 HEADER(2,32),DAT(2,512)
C
BYTE LINE(256)
INTEGER LINEL
CHARACTER*64 IFILE,OFILE
INTEGER IFILEL,OFILEL
INTEGER LND
C
INCLUDE 'DMPHEAD.FOR/NOLIST'
C
WRITE(6,10)
10 FORMAT('$Enter name of file: ')
READ(5,20) IFILEL,IFILE
20 FORMAT(Q,A)
OPEN(UNIT=1,NAME=IFILE(1:IFILEL),RECORDSIZE=2720,TYPE='OLD',
1 READONLY)
WRITE(6,30)
30 FORMAT('$Enter the output file name:')
READ(5,20) OFILEL,OFILE
OPEN(UNIT=2,NAME=OFILE(1:OFILEL),TYPE='NEW',RECORDSIZE=512,
1 CARRIAGECONTROL='FORTRAN')
C
C GET A HEADER...
C
35 READ(1,20,END=1000) JUNKL,JUNK
CALL CVT36(JHEAD,HEADER,32)
I = HEADER(1,1)
LND = '3FFFF'X.AND.HEADER(1,G$LND)
GOTO (100,200,300,400,500,600,700) I
WRITE(6,40) HEADER(2,1),HEADER(1,1)
40 FORMAT(' HEADER WORD IS ',I,' / ',I)
GOTO 35
C
100 CONTINUE
WRITE(2,110)
110 FORMAT(' FOUND A WORTHLESS LABEL RECORD')
GOTO 35
C
200 CONTINUE
LINEL = 1
CALL CVTDATE(HEADER(1,S$DATE),LINE,LINEL)
WRITE(2,210) (LINE(I),I=1,LINEL-1)
210 FORMAT(' START OF SAVE SET WRITTEN AT ',256(A1,:))
LINEL = 1
CALL CVTSIX(HEADER(1,S$DEV),LINE,LINEL)
WRITE(2,220) HEADER(1,S$SVER),HEADER(1,S$FMT),HEADER(1,S$BVER),
1 HEADER(1,S$APR),(LINE(I),I=1,LINEL-1)
220 FORMAT(' WITH SYSTEM VERSION ',O12,' BACKUP FORMAT = ',O12,/,
1 ' BACKUP VERSION ',O12,' USING CPU SERIAL NUMBER ',O12,/,
2 ' AND MAGTAPE DRIVE ',256(A1,:))
IF (LND.NE.0) CALL OVERHEAD(2,JDATA,LND)
GOTO 35
C
300 CONTINUE
LINEL = 1
CALL CVTDATE(HEADER(1,S$DATE),LINE,LINEL)
WRITE(2,310) (LINE(I),I=1,LINEL-1)
310 FORMAT(' END OF SAVE SET WRITTEN AT ',256(A1,:))
LINEL = 1
CALL CVTSIX(HEADER(1,S$DEV),LINE,LINEL)
WRITE(2,320) HEADER(1,S$SVER),HEADER(1,S$FMT),HEADER(1,S$BVER),
1 HEADER(1,S$APR),(LINE(I),I=1,LINEL-1)
320 FORMAT(' WITH SYSTEM VERSION ',O12,' BACKUP FORMAT = ',O12,/,
1 ' BACKUP VERSION ',O12,' USING CPU SERIAL NUMBER ',O12,/,
2 ' AND MAGTAPE DRIVE ',256(A1,:))
IF (LND.NE.0) CALL OVERHEAD(2,JDATA,LND)
GOTO 35
C
400 CONTINUE
IF (LND.NE.0) CALL OVERHEAD(2,JDATA,LND)
GOTO 35
C
500 CONTINUE
WRITE(6,510)
510 FORMAT(' UFD RECORD READ')
GOTO 35
C
600 CONTINUE
WRITE(6,610)
610 FORMAT(' END OF VOLUME???')
GOTO 35
C
700 CONTINUE
WRITE(6,710)
710 FORMAT(' COMMENT?')
GOTO 35
C
1000 CONTINUE
CLOSE(UNIT=1)
CLOSE(UNIT=2)
END
.TITLE ERRORM Error message reporting tool
;+
; This routine simplifies the reporting of errors
; by taking a single argument (the error number) and
; using $PUTMSG to deliver it to the user. No checking
; of any kind is done and the routine is re-entrant.
;-
.ENTRY ERRORM,0
;+
; Allocate the storage on the stack for the message
; vector. Since this will be a singularly stupid routine,
; the message vector will always be 8 bytes (flags=0,
; arg count=1, and message number as supplied).
;-
MOVZBL (AP),R0
SOBGTR R0,HAVEARGS ; FAO arguments supplied
BRB NOARGS
;
HAVEARGS:
ASHL #2,R0,R1
ADDL2 #12,R1
SUBL2 R1,SP
ASHL #-2,R1,(SP)
MOVW #0,2(SP)
MOVL @4(AP),4(SP)
MOVL R0,8(SP)
MOVAL 8(AP),R1
MOVAL 12(SP),R2
FAOL:
MOVL (R1)+,(R2)+
SOBGTR R0,FAOL
BRB PM
;
NOARGS:
SUBL2 #8,SP
MOVW #1,(SP)
MOVW #0,2(SP)
MOVL @4(AP),4(SP)
PM:
MOVL SP,R0
$PUTMSG_S (R0),,
RET
;
.END
PROGRAM IBM2VAX
C
C A FRESH START ON A PROGRAM TO READ EBCDIC LABELLED AND
C UNLABELLED TAPES.
C
C MTREC -- THE RECORD READ IN FROM THE TAPE
C FILENM -- THE FILENAME OF THE OUTPUT FILE
C FILELN -- THE LENGTH OF THE FILE NAME
C TAPE -- THE DEVICE NAME OF THE MAGTAPE
C CHAN -- CHANNEL NUMBER ASSIGNED TO TAPE
C MTLEN -- LENGTH OF MAGTAPE DATA READ IN
C STATUS -- STATUS CODE FROM SYSTEM & INTERNAL ROUTINES
C VOLREC -- VOLUME ID RECORD
C HDRREC -- HEADER ID RECORD
C LBL -- LABEL FLAG (L=YES, U=NO)
C
CHARACTER*32767 MTREC
CHARACTER*64 FILENM
INTEGER*2 FILELN
CHARACTER*6 TAPE
INTEGER*4 CHAN
INTEGER*4 MTLEN
INTEGER*4 STATUS
CHARACTER*80 VOLREC,HDRREC
CHARACTER*1 LBL
C
C VOL1 VOLUME LABEL INFORMATION
C VOLID -- VOLUME ID (VOL1, BUT OTHERS WILL BE IGNORED)
C VOLNAM -- VOLUME NAME (NAME OF THE TAPE)
C OWNER -- OWNER'S NAME (WHATEVER THAT MIGHT BE)
C VERSION -- VERSION OF THE TAPE LABELS (1,2, OR 3)
C
CHARACTER*4 VOLID
CHARACTER*6 VOLNAM
CHARACTER*13 OWNER
CHARACTER*1 VERSION
EQUIVALENCE (VOLREC(1:1),VOLID),(VOLREC(5:5),VOLNAM)
EQUIVALENCE (VOLREC(38:38),OWNER),(VOLREC(80:80),VERSION)
C
C HDR1 FILE HEADER INFORMATION
C HDRID -- HEADER ID (HDR1 OR HDR2, OTHERS IGNORED)
C FILEID -- NAME OF FILE ON TAPE
C CRDATE -- CREATION DATE ( YYDDD, YY-YEAR, DDD-DAY NUM (1-366)
C
CHARACTER*4 HDRID
CHARACTER*17 FILEID
CHARACTER*6 CRDATE
EQUIVALENCE (HDRREC(1:1),HDRID),(HDRREC(5:5),FILEID)
EQUIVALENCE (HDRREC(42:42),CRDATE)
C
C HDR1 FILE HEADER INFORMATION
C RECFMT -- RECORD FORMAT (F-FIXED, D-VARIABLE, U-UNDEFINED)
C BLKSIZ -- BLOCK SIZE, ZERO FILLED
C RECSIZ -- RECORD SIZE, ZERO FILLED
C BOL -- BUFFER OFFSET LENGTH (COMMONLY SKIPS BLOCK SEQ. NO)
C
CHARACTER*1 RECFMT
CHARACTER*5 BLKSIZ
CHARACTER*5 RECSIZ
CHARACTER*2 BOL
EQUIVALENCE (HDRREC(5:5),RECFMT),(HDRREC(6:6),BLKSIZ)
EQUIVALENCE (HDRREC(11:11),RECSIZ),(HDRREC(51:51),BOL)
C
C VARIABLES USED FOR UNBLOCKING DATA
C BLKLEN -- BLOCK LENGTH
C RECLEN -- RECORD LENGTH
C LABELS -- IF TRUE, THE TAPE HAS LABELS
C DBLANK -- IF TRUE, REMOVE TRAILING BLANKS
C ANS -- ANSWER TO YES/NO QUESTION
C
INTEGER*4 BLKLEN,RECLEN
LOGICAL LABELS
LOGICAL DBLANK
CHARACTER*1 ANS
C
C EXTERNAL ACCESS
C
C
INTEGER*4 SYS$ASSIGN
EXTERNAL SS$_ENDOFFILE
EXTERNAL SS$_ENDOFTAPE
C
C INITIAL DATA VALUES
C
DATA BLKLEN,RECLEN/80,80/
C
C BEGIN BY ASKING THE USER WHICH MAGTAPE TO USE
C
WRITE(5,10)
10 FORMAT('$Enter the tape drive name: ')
READ(6,20) TAPE
20 FORMAT(A)
CALL STR$UPCASE(TAPE,TAPE)
STATUS = SYS$ASSIGN(TAPE,CHAN,,)
IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
CALL REWMT(CHAN,STATUS)
IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
C
C NOW THAT WE HAVE THE MAGTAPE DRIVE ASSIGNED,
C ASK THE USER IF THE TAPE HAS LABELS.
C
30 CONTINUE
WRITE(5,40)
40 FORMAT('$Is the tape labelled (L) or unlabelled (U)? ')
READ(6,20) LBL
CALL STR$UPCASE(LBL,LBL)
IF (LBL.EQ.'L') GOTO 100
IF (LBL.EQ.'U') GOTO 500
WRITE(5,50)
50 FORMAT(' What?')
GOTO 30
C
C A LABELLED TAPE... CHECK OUT THE VOLUME ID
C
100 CONTINUE
MTLEN = 32767
CALL READMT(CHAN,MTREC,MTLEN,STATUS)
IF (.NOT.STATUS) THEN
IF (STATUS.EQ.%LOC(SS$_ENDOFTAPE)) GOTO 1000
IF (STATUS.EQ.%LOC(SS$_ENDOFFILE)) GOTO 150
WRITE(6,110)
110 FORMAT(' Error reading tape label')
CALL LIB$STOP(STATUS)
ENDIF
IF (MTLEN.NE.80) THEN
WRITE(6,120) MTLEN
120 FORMAT(' Tape label is not 80 bytes long, was ',i5,' bytes long')
GOTO 10000
ENDIF
CALL LIB$TRA_EBC_ASC(MTREC(1:80),VOLREC)
IF (VOLID(1:3).NE.'VOL') THEN
WRITE(6,130) VOLREC
130 FORMAT(' Invalid volume label:',/,A80)
GOTO 10000
ENDIF
IF (VOLID(4:4).EQ.'1') THEN
WRITE(6,140) VOLNAM,OWNER,VERSION
140 FORMAT(' VOLUME HEADER:',/,' TAPE NAME = "',A,'" OWNER = "',
1 A,'"',/,' VOLUME LABELS ARE TYPE ',A)
ELSE
GOTO 100
ENDIF
N = 1
CALL SKIPF(CHAN,N,STATUS)
IF (.NOT.STATUS) THEN
CALL LIB$STOP(STATUS)
ENDIF
C
C LOOK AT THE FILE HEADER(S)
C
150 CONTINUE
C
C AN UNLABELLED TAPE... GET THE INFO FROM THE USER
C
500 CONTINUE
WRITE(6,510)
510 FORMAT(' Enter SKIP to skip a file, STOP to quit, or',
1 'a filename to read a file',/,'$Action:')
READ(5,520) FILELN,FILENM
520 FORMAT(Q,A)
CALL STR$UPCASE(FILENM(1:FILELN),FILENM(1:FILELN))
IF (FILENM(1:4).EQ.'STOP') GOTO 10000
IF (FILENM(1:FILELN).EQ.'SKIP') THEN
WRITE(6,530)
530 FORMAT('$Skip how many files? ')
READ(5,*) N
CALL SKIPF(CHAN,N,STATUS)
IF (.NOT.STATUS) THEN
WRITE(6,540) N
540 FORMAT(' Error detected skipping files,',i5,' files skipped')
ENDIF
GOTO 500
ENDIF
C
C GET THE BLOCK LENGTH AND RECORD LENGTH FROM
C THE USER FOR THIS FILE.
C
WRITE(6,550) RECLEN
550 FORMAT('$Enter the record length (Default=',I5,'): ')
READ(5,*) N
IF (N.NE.0) RECLEN = N
WRITE(6,560) BLKLEN
560 FORMAT('$Enter the block length (Default=',I5,'): ')
READ(5,*) N
IF (N.NE.0) BLKLEN = N
IF (MOD(BLKLEN,RECLEN).NE.0) WRITE(6,570)
570 FORMAT(' ?Blocksize is not a multiple of record size')
C
C OPEN THE OUTPUT FILE
C
OPEN(UNIT=1,NAME=FILENM(1:FILELN),TYPE='NEW',INITIALSIZE=1,
1 EXTENDSIZE=1,CARRIAGECONTROL='LIST',RECL=MIN(RECLEN,256),
2 ERR=580)
GOTO 600
C
580 CONTINUE
WRITE(6,590) FILENM(1:FILELN)
590 FORMAT(' Error opening file ',A)
GOTO 500
C
C COPY THE DATA FROM THE TAPE AND PUT IT INTO THE FILE
C
600 CONTINUE
WRITE(6,610)
610 FORMAT('$Do you wish to remove trailing blanks? ')
READ(5,620) ANS
620 FORMAT(A)
CALL STR$UPCASE(ANS,ANS)
IF (ANS.EQ.'Y') THEN
DBLANK = .TRUE.
ELSE IF (ANS.EQ.'N') THEN
DBLANK = .FALSE.
ELSE
GOTO 600
ENDIF
C
C FINALLY, PROCESS THE UNLABELLED TAPE
C
630 CONTINUE
MTLEN = 32767
CALL READMT(CHAN,MTREC,MTLEN,STATUS)
IF (.NOT.STATUS) THEN
IF (STATUS.EQ.%LOC(SS$_ENDOFFILE)) GOTO 700
IF (STATUS.EQ.%LOC(SS$_ENDOFTAPE)) THEN
CLOSE(UNIT=1)
GOTO 1000
ENDIF
WRITE(6,640)
640 FORMAT(' Error reading the magtape')
CALL LIB$STOP(STATUS)
ENDIF
IF (MTLEN.GT.0) THEN
CALL LIB$TRA_EBC_ASC(MTREC(1:MTLEN),MTREC(1:MTLEN))
DO I=1,MTLEN,RECLEN
IF (DBLANK) THEN
DO J=I+RECLEN-1,I,-1
IF (MTREC(J:J).NE.' ') GOTO 650
ENDDO
650 CONTINUE
WRITE(1,660) MTREC(I:J)
ELSE
WRITE(1,660) MTREC(I:I+RECLEN-1)
ENDIF
ENDDO
ENDIF
660 FORMAT(A)
GOTO 630
C
C END OF FILE FOR UNFORMATTED READ
C CLOSE THE OUTPUT FILE & GO ON
C
700 CONTINUE
CLOSE(UNIT=1)
WRITE(6,710)
710 FORMAT(' Done')
GOTO 600
C
C END OF TAPE, GIVE THE USER SOME OPTIONS
C
1000 CONTINUE
WRITE(6,1010)
1010 FORMAT(' End of tape reached',/,
1 '$Do you wish to Exit (E), Rewind (R), or Unload and exit(U)? ')
READ(5,1020) ANS
1020 FORMAT(A)
CALL STR$UPCASE(ANS,ANS)
IF (ANS.EQ.'E') GOTO 10000
IF (ANS.EQ.'R') THEN
CALL REWMT(CHAN,STATUS)
IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
IF (LBL.EQ.'L') GOTO 100
GOTO 500
ELSE IF (ANS.EQ.'U') THEN
CALL UNLOMT(CHAN,STATUS)
IF (.NOT.STATUS) CALL LIB$STOP(STATUS)
GOTO 10000
ELSE
WRITE(6,1030)
1030 FORMAT(' What?')
GOTO 1000
ENDIF
C
C ALL DONE, EXIT
C
10000 CONTINUE
END
SUBROUTINE READMT(CHAN,REC,LENGTH,STATUS)
C
C A SUBROUTINE TO READ A MAGTAPE RECORD USING LOGICAL I/O
C CHAN IS THE CHANNEL ASSIGNED TO THE MAGTAPE
C REC IS THE RECORD TO READ THE DATA INTO
C LENGTH IS THE LENGTH OF THE DATA READ IN
C STATUS IS THE CODE RETURNED BY THE SYSTEM SERVICE CALL
C
INTEGER*4 CHAN
CHARACTER*32767 REC
INTEGER*4 LENGTH
INTEGER*4 STATUS
C
C IOSB -- THE I/O STATUS BLOCK
C
INTEGER*2 IOSB(4)
C
C SYSTEM EXTERNAL VALUES
C
EXTERNAL IO$_READLBLK
INTEGER*4 SYS$QIOW
C
STATUS = SYS$QIOW(,%VAL(CHAN),IO$_READLBLK,IOSB,
1 ,,%REF(REC),%VAL(LENGTH),,,,,)
IF (.NOT.STATUS) THEN
WRITE(6,10)
10 FORMAT(' Error reading the magtape')
CALL LIB$STOP(STATUS)
ELSE
STATUS = IOSB(1)
LENGTH = IOSB(2)
ENDIF
RETURN
END
SUBROUTINE SKIPF(CHAN,N,STATUS)
C
C A SUBROUTINE TO SKIP A FILE
C CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C N IS THE NUMBER OF FILES TO SKIP (NEGATIVE FOR BACKWARDS)
C STATUS IS THE STATUS OF THE MAGTAPE
C
INTEGER*4 CHAN,N,STATUS
INTEGER*2 IOSB(4)
C
C EXTERNAL ACCESS
C
EXTERNAL IO$_SKIPFILE
INTEGER*4 SYS$QIOW
C
STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_SKIPFILE,IOSB,
1 ,,%VAL(N),,,,,)
IF (.NOT.STATUS) THEN
WRITE(6,10)
10 FORMAT(' Error skipping files on the magtape')
CALL LIB$STOP(STATUS)
ELSE
STATUS = IOSB(1)
N = IOSB(2)
ENDIF
RETURN
END
SUBROUTINE SKIPR(CHAN,N,STATUS)
C
C A SUBROUTINE TO SKIP A RECORD
C CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C N IS THE NUMBER OF RECORDS TO SKIP (NEGATIVE FOR BACKWARDS)
C STATUS IS THE STATUS OF THE MAGTAPE
C
INTEGER*4 CHAN,N,STATUS
INTEGER*2 IOSB(4)
C
C EXTERNAL ACCESS
C
EXTERNAL IO$_SKIPRECORD
INTEGER*4 SYS$QIOW
C
STATUS = SYS$QIOW(,%VAL(ICHAN),IO$_SKIPRECORD,IOSB,
1 ,,%VAL(N),,,,,)
IF (.NOT.STATUS) THEN
WRITE(6,10)
10 FORMAT(' Error skipping records on the magtape')
CALL LIB$STOP(STATUS)
ELSE
STATUS = IOSB(1)
N = IOSB(2)
ENDIF
RETURN
END
SUBROUTINE REWMT(CHAN,STATUS)
C
C THIS SUBROUTINE WILL REWIND A MAGTAPE TO THE LOAD POINT
C CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C STATUS IS THE RETURNED STATUS OF THE TAPE
C
INTEGER*4 CHAN,STATUS
INTEGER*2 IOSB(4)
C
C EXTERNAL ACCESS
C
EXTERNAL IO$_REWIND
INTEGER*4 SYS$QIOW
C
STATUS = SYS$QIOW(,%VAL(CHAN),IO$_REWIND,IOSB,
1 ,,,,,,,)
IF (.NOT.STATUS) THEN
WRITE(6,10)
10 FORMAT(' Error rewinding the magtape')
CALL LIB$STOP(STATUS)
ELSE
STATUS = IOSB(1)
ENDIF
RETURN
END
SUBROUTINE UNLOMT(CHAN,STATUS)
C
C THIS SUBROUTINE WILL UNLOAD A MAGTAPE
C CHAN IS THE CHANNEL NUMBER OF THE MAGTAPE
C STATUS IS THE RETURNED STATUS OF THE TAPE
C
INTEGER*4 CHAN,STATUS
INTEGER*2 IOSB(4)
C
C EXTERNAL ACCESS
C
EXTERNAL IO$_REWINDOFF
INTEGER*4 SYS$QIOW
C
STATUS = SYS$QIOW(,%VAL(CHAN),IO$_REWINDOFF,IOSB,
1 ,,,,,,,)
IF (.NOT.STATUS) THEN
WRITE(6,10)
10 FORMAT(' Error unloading the magtape')
CALL LIB$STOP(STATUS)
ELSE
STATUS = IOSB(1)
ENDIF
RETURN
END
PROGRAM MONKEY
C
C A PROGRAM TO LOOK AT BACKUP SAVE SETS.
C
CHARACTER*2720 JUNK
BYTE JHEAD(160),JDATA(2560)
EQUIVALENCE (JUNK,JHEAD),(JUNK(161:161),JDATA)
C
INTEGER*4 HEADER(2,32),DAT(2,512)
C
CHARACTER*2560 LINE
BYTE LINEB(2560)
EQUIVALENCE (LINE,LINEB)
CHARACTER*64 IFILE,OFILE
INTEGER IFILEL,OFILEL
C
WRITE(6,10)
10 FORMAT('$Enter name of file: ')
READ(5,20) IFILEL,IFILE
20 FORMAT(Q,A)
OPEN(UNIT=1,NAME=IFILE(1:IFILEL),RECORDSIZE=2720,TYPE='OLD')
WRITE(6,30)
30 FORMAT('$Enter the output file name:')
READ(5,20) OFILEL,OFILE
OPEN(UNIT=2,NAME=OFILE(1:OFILEL),TYPE='NEW',RECORDSIZE=512,
1 CARRIAGECONTROL='NONE')
C
C GET A HEADER...
C
35 READ(1,20,END=1000) JUNKL,JUNK
CALL CVT(JHEAD,HEADER,32)
I = HEADER(1,1)
GOTO (100,200,300,400,500,600,700) I
WRITE(6,40) HEADER(2,1),HEADER(1,1)
40 FORMAT(' HEADER WORD IS ',I,' / ',I)
GOTO 35
C
100 CONTINUE
WRITE(6,110)
110 FORMAT(' FOUND A WORTHLESS LABEL RECORD')
GOTO 35
C
200 CONTINUE
WRITE(6,210)
210 FORMAT(' START OF SAVE SET')
GOTO 35
C
300 CONTINUE
WRITE(6,310)
310 FORMAT(' END OF SAVE SET')
GOTO 35
C
400 CONTINUE
IF (HEADER(1,6).NE.0) THEN
CALL CVT(JDATA,DAT,HEADER(1,6))
DO I=1,HEADER(1,6),1
J=1+(I-1)*5
LINEB(J) = LIB$EXTZV(29,7,DAT(1,I))
LINEB(J+1) = LIB$EXTZV(22,7,DAT(1,I))
LINEB(J+2) = LIB$EXTZV(15,7,DAT(1,I))
LINEB(J+3) = LIB$EXTZV(8,7,DAT(1,I))
LINEB(J+4) = LIB$EXTZV(1,7,DAT(1,I))
ENDDO
DO I=1,J-508,512
WRITE(2,410) LINE(I:I+511)
410 FORMAT(A)
ENDDO
WRITE(2,410) LINE(I:J+4)
IF (IAND(8,HEADER(2,4)).NE.0) THEN
WRITE(6,420)
420 FORMAT(' END OF FILE REACHED')
CLOSE(UNIT=2)
ENDIF
ENDIF
GOTO 35
C
500 CONTINUE
WRITE(6,510)
510 FORMAT(' UFD RECORD READ')
GOTO 35
C
600 CONTINUE
WRITE(6,610)
610 FORMAT(' END OF VOLUME???')
GOTO 35
C
700 CONTINUE
WRITE(6,710)
710 FORMAT(' COMMENT?')
GOTO 35
C
1000 CONTINUE
CLOSE(UNIT=1)
CLOSE(UNIT=2)
END
SUBROUTINE CVT(A,B,N)
C
C TO CONVERT A STRING FROM 36BITS IN 5 BYTES TO
C 36 BITS IN 8 BYTES (ALL ALIGNED PROPERLY)
C
BYTE A(1)
INTEGER B(2,N)
C
DO J=1,N,1
I=1+(J-1)*5
CALL LIB$INSV(A(I),28,8,B(1,J))
CALL LIB$INSV(A(I+1),20,8,B(1,J))
CALL LIB$INSV(A(I+2),12,8,B(1,J))
CALL LIB$INSV(A(I+3),4,8,B(1,J))
CALL LIB$INSV(A(I+4),0,4,B(1,J))
ENDDO
RETURN
END
SUBROUTINE MTOPEN(NAME,CHANNEL,STATUS)
C
C This subroutine will use the VAX/VMS system services
C to open a magtape drive and return the channel number
C assigned to it. If an error occurs, the STATUS code
C will be even.
C
CHARACTER*64 DEVNAME
INTEGER*2 DEVLEN
CHARACTER*(*) NAME
INTEGER*4 CHANNEL,STATUS
INTEGER*4 SYS$ASSIGN
C
CALL STR$UPCASE(DEVNAME,NAME)
DEVLEN = MIN(64,LEN(NAME))
STATUS = SYS$ASSIGN(DEVNAME(1:DEVLEN),CHANNEL,,)
RETURN
END
SUBROUTINE MTCLOS(CHANNEL,STATUS)
C
C This subroutine will use the VAX/VMS system services
C to close the magtape drive previously opened by MTOPEN.
C If an error occurs, the STATUS code will be even.
C
INTEGER*4 CHANNEL,STATUS
INTEGER*4 SYS$DASSGN
C
STATUS = SYS$DASSGN(%VAL(CHANNEL))
RETURN
END
SUBROUTINE MTSKPF(CHANNEL,COUNT,STATUS)
C
C This subroutine will use the VAX/VMS system services
C to skip the magtape the specified number of files for
C a tape drive previously opened by MTOPEN. If an error
C occurs, the STATUS code will be even.
C
INTEGER*4 CHANNEL,COUNT,STATUS
INTEGER*4 IOSB(2)
INTEGER*2 IOSB2(4)
EQUIVALENCE (IOSB,IOSB2)
C
EXTERNAL IO$_SKIPFILE,MT$M_BOT
C
IF (COUNT.LE.0) THEN
CALL MTCONT(CHANNEL,IO$_SKIPFILE,COUNT-1,IOSB,STATUS)
10 FORMAT(' Skipped',I5,' files')
IF (IAND(%LOC(MT$M_BOT),IOSB(2)).EQ.0) THEN
WRITE(*,10) MIN(0,-IOSB2(2)+1)
CALL MTCONT(CHANNEL,IO$_SKIPFILE,1,IOSB,STATUS)
ELSE
WRITE(*,10) MIN(0,-IOSB2(2))
ENDIF
ELSE
CALL MTCONT(CHANNEL,IO$_SKIPFILE,COUNT,IOSB,STATUS)
WRITE(*,10) IOSB2(2)
ENDIF
CALL MTSTAT(IOSB)
RETURN
END
SUBROUTINE MTSKPR(CHANNEL,COUNT,STATUS)
C
C This subroutine will use the VAX/VMS system services
C to skip the magtape the specified number of records for
C a tape drive previously opened by MTOPEN. If an error
C occurs, the STATUS code will be even.
C
INTEGER*4 CHANNEL,COUNT,STATUS
INTEGER*4 IOSB(2)
INTEGER*2 IOSB2(4)
EQUIVALENCE (IOSB,IOSB2)
C
EXTERNAL IO$_SKIPRECORD
C
CALL MTCONT(CHANNEL,IO$_SKIPRECORD,COUNT,IOSB,STATUS)
WRITE(*,10) SIGN(IOSB2(2),COUNT)
10 FORMAT(' Skipped',I5,' records')
CALL MTSTAT(IOSB)
RETURN
END
SUBROUTINE MTCONT(CHANNEL,ACTION,COUNT,IOSB,STATUS)
C
C This subroutine is used by MTSKPF and MTSKPR to
C do the actual work of skipping on the magtape.
C This will interpret the system and magtape status
C codes and print the appropriate messages.
C
INTEGER*4 CHANNEL,ACTION,COUNT,STATUS
INTEGER*2 IOSB(4)
C
C
INTEGER*4 SYS$QIOW
EXTERNAL IO$_SENSEMODE
C
STATUS = SYS$QIOW(,%VAL(CHANNEL),ACTION,IOSB,,
1 ,%VAL(COUNT),,,,,)
IF (.NOT.STATUS) THEN
CALL ERRORM(STATUS)
ELSE IF (.NOT.IOSB(1)) THEN
STATUS = IOSB(1)
CALL ERRORM(STATUS)
ENDIF
RETURN
END
SUBROUTINE MTSTAT(IOSB)
C
C This subroutine will examine the I/O status block
C supplied and print the appropriate messages.
C
INTEGER*4 IOSB(2)
C
EXTERNAL MT$M_LOST,MT$M_EOT,MT$M_BOT
EXTERNAL MTIO_LOST,MTIO_EOT,MTIO_BOT
C
IF (IAND(%LOC(MT$M_LOST),IOSB(2)).NE.0)
1 CALL ERRORM(%LOC(MTIO_LOST))
IF (IAND(%LOC(MT$M_EOT),IOSB(2)).NE.0)
1 CALL ERRORM(%LOC(MTIO_EOT))
IF (IAND(%LOC(MT$M_BOT),IOSB(2)).NE.0)
1 CALL ERRORM(%LOC(MTIO_BOT))
C
RETURN
END
SUBROUTINE MTREAD(CHANNEL,BUFFER,BUFLEN,ACTLEN,STATUS)
C
C This subroutine will read a magtape that has been opened
C by the MTOPEN subroutine. It will read in one record from
C the tape into BUFFER, and set ACTLEN to the number of bytes
C actually read. STATUS will get the return status from the
C VAX/VMS $QIOW call.
C
INTEGER*4 CHANNEL,BUFLEN,ACTLEN,STATUS
BYTE BUFFER(1)
C NB: BUFFER is dimensioned 1 due to FORTRAN problems...it should be
C dimensioned to BUFLEN.
C
INTEGER*4 SYS$QIOW
INTEGER*2 IOSB(4)
EXTERNAL IO$_READLBLK
C
STATUS = SYS$QIOW(,%VAL(CHANNEL),IO$_READLBLK,IOSB,,
1 ,BUFFER,%VAL(BUFLEN),,,,)
ACTLEN = IOSB(2)
IF (.NOT.STATUS) THEN
CALL ERRORM(STATUS)
ELSE
IF (.NOT.IOSB(1)) THEN
STATUS = IOSB(1)
CALL ERRORM(STATUS)
ENDIF
ENDIF
CALL MTSTAT(IOSB)
RETURN
END
SUBROUTINE MTWRIT(CHANNEL,BUFFER,BUFLEN,ACTLEN,STATUS)
C
C This subroutine will write a magtape that has been opened
C by the MTOPEN subroutine. It will write out one record from
C BUFFER to the tape, and set ACTLEN to the number of bytes
C actually written. STATUS will get the return status from the
C VAX/VMS $QIOW call.
C
INTEGER*4 CHANNEL,BUFLEN,ACTLEN,STATUS
BYTE BUFFER(1)
C NB: BUFFER is dimensioned 1 due to FORTRAN problems...it should be
C dimensioned to BUFLEN.
C
INTEGER*4 SYS$QIOW
INTEGER*2 IOSB(4)
EXTERNAL IO$_WRITELBLK
C
STATUS = SYS$QIOW(,%VAL(CHANNEL),IO$_WRITELBLK,IOSB,,
1 ,BUFFER,%VAL(BUFLEN),,,,)
ACTLEN = IOSB(2)
IF (.NOT.STATUS) THEN
CALL ERRORM(STATUS)
ELSE
IF (.NOT.IOSB(1)) THEN
STATUS = IOSB(1)
CALL ERRORM(STATUS)
ENDIF
ENDIF
CALL MTSTAT(IOSB)
RETURN
END
.TITLE MTIOMSG MTIO error and information messages
.FACILITY MTIO,2050
.SEVERITY WARNING
LOST <The magtape position has been lost>
EOT <The end of tape has been reached>
BOT <The beginning of tape has been reached>
.END
SUBROUTINE OVERHEAD(BUFFER,BLEN,FSPEC,FSLEN)
C
C This segment examines the overhead section of the
C file data. The data is printed on the user's terminal.
C
C
C Parameter list description:
C
C BUFFER -- Raw data of the input buffer
C BLEN -- Length of the overhead region in words
C FSPEC -- File specification to return to caller
C FSLEN -- Length of the file specification returned
C
INTEGER*4 BUFLEN
PARAMETER (BUFLEN=2720)
BYTE BUFFER(BUFLEN)
INTEGER*4 BLEN
CHARACTER*256 FSPEC
INTEGER*4 FSLEN
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPHEAD.FOR/NOLIST'
INCLUDE 'DMPREC.FOR/NOLIST'
C
C Local data description:
C
INTEGER*4 DAT(2,512)
C
INTEGER RH,LH
INTEGER RHS,LHS
CHARACTER*5 CHARS
CHARACTER*20 DATIME
BYTE LINE(256)
INTEGER LINEL
CHARACTER*256 CLINE
EQUIVALENCE (LINE,CLINE)
BYTE NUM(8)
CHARACTER CNUM*8
EQUIVALENCE (NUM,CNUM)
C
FSLEN = 0
IF (BLKTYP.EQ.STDBLK) THEN
CALL CVT36(BUFFER(161),DAT,BLEN)
ELSE
CALL CVT72(BUFFER(145),DAT,BLEN)
ENDIF
K = BLEN
I = 1
LINEL = 1
DO WHILE (K.GT.I)
CALL CVTHALF(DAT(1,I),RH,LH)
GOTO (905,100,200,300,400,500) LH+1
WRITE(6,10) I,RH,LH
10 FORMAT(' ERROR WITH OVERHEAD RECORD, WORD=',I3,' VALUE = ',
1 2O8.6)
GOTO 1000
C
C NAME RECORD
C
100 CONTINUE
J = 1+I
CALL CVTHALF(DAT(1,J),RHS,LHS)
IF (LHS.EQ.N$DEV) THEN
CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
J = J+RHS
CALL CVTHALF(DAT(1,J),RHS,LHS)
LINE(LINEL) = ':'
LINEL = LINEL+1
ENDIF
IF (LHS.EQ.N$UFD) THEN
LINE(LINEL) = '['
LINEL = LINEL+1
CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
J = J+RHS
CALL CVTHALF(DAT(1,J),RHS,LHS)
DO WHILE (LHS.GT.N$UFD)
LINE(LINEL) = ','
LINEL = LINEL+1
CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
J = J+RHS
CALL CVTHALF(DAT(1,J),RHS,LHS)
ENDDO
LINE(LINEL) = ']'
LINEL = LINEL+1
ENDIF
IF (LHS.EQ.N$NAME) THEN
IF (LINEL.EQ.1) THEN
LINEL = 4
LINE(1) = '['
LINE(2) = '_'
LINE(3) = ']'
ENDIF
CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
J = J+RHS
CALL CVTHALF(DAT(1,J),RHS,LHS)
ENDIF
LINE(LINEL) = '.'
LINEL = LINEL+1
IF (LHS.EQ.N$EXT) THEN
CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
J = J+RHS
CALL CVTHALF(DAT(1,J),RHS,LHS)
ENDIF
IF (LHS.EQ.N$VER) THEN
J = J+RHS
CALL CVTHALF(DAT(1,J),RHS,LHS)
ENDIF
IF (LHS.EQ.N$GEN) THEN
LINE(LINEL) = ';'
LINEL = LINEL+1
CALL CVTASZ(DAT(1,J+1),LINE,LINEL)
ENDIF
FSLEN = LINEL-1
DO I=1,FSLEN
IF (LINE(I).EQ.'-') LINE(I) = '_'
ENDDO
FSPEC(1:FSLEN) = CLINE(1:FSLEN)
GOTO 900
C
C ATTRIBUTE SUB-BLOCK
C
200 CONTINUE
DO J=LINEL,38,1
LINE(J) = ' '
ENDDO
LINEL = MAX(39,LINEL)
LINE(LINEL) = ' '
LINEL = LINEL+1
WRITE(CNUM,210) (DAT(1,I+A$ALLS)+255)/256
210 FORMAT(I8)
DO J=1,8
LINE(LINEL-1+J) = NUM(J)
ENDDO
LINE(LINEL+8) = ' '
LINE(LINEL+9) = ' '
LINE(LINEL+10) = ' '
LINEL = LINEL+11
CALL CVTDATE(DAT(1,I+A$WRIT),LINE,LINEL)
GOTO 900
C
C DIRECTORY ATTRIBUTES
C
300 CONTINUE
GOTO 900
C
C SYSTEM NAME
C
400 CONTINUE
IF (LINEL.GT.1) THEN
LINEL = LINEL-1
IF (LIST) WRITE(2,910) (LINE(J),J=1,LINEL)
LINEL = 1
ENDIF
CALL CVTASZ(DAT(1,I+1),LINE,LINEL)
IF (LIST) WRITE(2,410) (LINE(J),J=1,LINEL-1)
410 FORMAT(' SYSTEM NAME = ',256(A1,:))
LINEL = 1
GOTO 900
C
C SAVE SET NAME
C
500 CONTINUE
IF (LINEL.GT.1) THEN
LINEL = LINEL-1
IF (LIST) WRITE(2,910) (LINE(J),J=1,LINEL)
LINEL = 1
ENDIF
CALL CVTASZ(DAT(1,I+1),LINE,LINEL)
IF (LIST) WRITE(2,510) (LINE(J),J=1,LINEL-1)
510 FORMAT(' SAVE SET NAME = ',256(A1,:))
LINEL = 1
GOTO 900
C
C GO TO THE NEXT REGION
C
900 CONTINUE
I = I+RH
ENDDO
C
905 CONTINUE
LINEL = LINEL-1
IF (LIST) WRITE(2,910) (LINE(J),J=1,LINEL)
910 FORMAT(1X,<LINEL>A1)
1000 CONTINUE
RETURN
END
PROGRAM PRINT
C
C A PROGRAM TO LOOK AT BACKUP SAVE SETS.
C
CHARACTER*2720 JUNK
BYTE JHEAD(160),JDATA(2560)
EQUIVALENCE (JUNK,JHEAD),(JUNK(161:161),JDATA)
C
INTEGER*4 HEADER(2,32),DAT(2,512)
C
CHARACTER*2560 LINE
BYTE LINEB(2560)
EQUIVALENCE (LINE,LINEB)
CHARACTER*64 IFILE,OFILE
INTEGER IFILEL,OFILEL
C
WRITE(6,10)
10 FORMAT('$Enter name of file: ')
READ(5,20) IFILEL,IFILE
20 FORMAT(Q,A)
OPEN(UNIT=1,NAME=IFILE(1:IFILEL),RECORDSIZE=2720,TYPE='OLD',
1 READONLY)
WRITE(6,30)
30 FORMAT('$Enter the output file name:')
READ(5,20) OFILEL,OFILE
OPEN(UNIT=2,NAME=OFILE(1:OFILEL),TYPE='NEW',RECORDSIZE=512,
1 CARRIAGECONTROL='FORTRAN')
C
C GET A HEADER...
C
35 READ(1,20,END=1000) JUNKL,JUNK
CALL CVT36(JHEAD,HEADER,32)
CALL WRITER(HEADER,32)
I = HEADER(1,1)
GOTO (100,200,300,400,500,600,700) I
WRITE(6,40) HEADER(2,1),HEADER(1,1)
40 FORMAT(' HEADER WORD IS ',I,' / ',I)
GOTO 800
C
100 CONTINUE
WRITE(2,110)
110 FORMAT(' FOUND A WORTHLESS LABEL RECORD')
GOTO 800
C
200 CONTINUE
WRITE(2,210)
210 FORMAT(' START OF SAVE SET')
GOTO 800
C
300 CONTINUE
WRITE(2,310)
310 FORMAT(' END OF SAVE SET')
GOTO 800
C
400 CONTINUE
WRITE(2,410)
410 FORMAT(' FILE DATA RECORD')
GOTO 800
C
500 CONTINUE
WRITE(2,510)
510 FORMAT(' UFD RECORD READ')
GOTO 800
C
600 CONTINUE
WRITE(2,610)
610 FORMAT(' END OF VOLUME???')
GOTO 800
C
700 CONTINUE
WRITE(2,710)
710 FORMAT(' COMMENT?')
GOTO 800
C
800 CONTINUE
CALL CVT36(JDATA,DAT,512)
CALL WRITER(DAT,512)
WRITE(2,810)
810 FORMAT('1')
GOTO 35
1000 CONTINUE
CLOSE(UNIT=1)
CLOSE(UNIT=2)
END
SUBROUTINE WRITER(VALUE,N)
C
C A SUBROUTINE TO CONVERT N TWO WORD VALUES
C FROM DEC-10 FORMAT INTO ASCII BY DOING
C SIXBIT, 7-BIT ASCII AND HALFWORD CONVERSIONS.
C
INTEGER SIVAL(6),AIVAL(5),HVAL(2)
CHARACTER*1 SVAL(6),AVAL(5)
INTEGER VALUE(2,N),N
C
BYTE LINE(20)
INTEGER LINEL
C
DO I=1,N,1
K = 1
DO J=30,0,-6
SIVAL(K) = LIB$EXTZV(J,6,VALUE(1,I))
SVAL(K) = CHAR(SIVAL(K)+32)
K = K+1
ENDDO
K = 1
DO J=29,1,-7
AIVAL(K) = LIB$EXTZV(J,7,VALUE(1,I))
IF (AIVAL(K).LE.32) THEN
AVAL(K) = ' '
ELSE
AVAL(K) = CHAR(AIVAL(K))
ENDIF
K = K+1
ENDDO
HVAL(1) = LIB$EXTZV(18,18,VALUE(1,I))
HVAL(2) = LIB$EXTZV(0,18,VALUE(1,I))
LINEL=1
CALL CVTDATE(VALUE(1,I),LINE,LINEL)
WRITE(2,20) I,SVAL,SIVAL,AVAL,AIVAL,HVAL,LINE
20 FORMAT(' Item ',i3,': ',6a1,2x,6z3.2,2x,5a1,2x,5z3.2,2x,2o7.6,
1 2X,20A1)
ENDDO
RETURN
END
SUBROUTINE PROCESS(BUFFER,HEADER)
C
C This subroutine will process a record of data
C that has been read from the Magtape. BUFFER
C holds the 'raw' data from the tape. HEADER has
C the header information already decoded by the
C GO_COMMAND as per the BLKTYP information.
C
C Parameter list description:
C
C BUFFER -- Raw data as read from the magtape
C HEADER -- Converted DEC 10/20 header record
C
INTEGER*4 BUFLEN
PARAMETER (BUFLEN=2720)
BYTE BUFFER(BUFLEN)
INTEGER*4 HEADER(2,32)
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPHEAD.FOR/NOLIST'
C
C FILEDATA -- Converted DEC 10/20 file information
C LENDATA -- Length of the file information
C
INTEGER*4 FILEDATA(2,512)
INTEGER*4 LENDATA
C
CALL PREPROC(BUFFER,HEADER)
IF (FILEOK) THEN
LENDATA = HEADER(1,G$SIZ)
IF (LENDATA.EQ.0) RETURN
IF (BLKTYP.EQ.STDBLK) THEN
CALL CVT36(BUFFER(161+5*HEADER(1,G$LND)),FILEDATA,LENDATA)
ELSE
CALL CVT72(BUFFER(145+9*(HEADER(1,G$LND)/2)),FILEDATA,LENDATA)
ENDIF
CALL DATAPROC(FILEDATA,HEADER)
ENDIF
CALL POSTPROC(BUFFER,HEADER)
RETURN
END
SUBROUTINE PREPROC(BUFFER,HEADER)
C
C This segment will do the pre-processing that is necessary
C to handle a block from the tape. This includes the
C examination of the filename, opening the output file, and
C setting program status codes to indicate the progress of
C the job.
C
C Parameter list description:
C
C BUFFER -- Raw data from tape
C HEADER -- Header information after conversion
C
INTEGER*4 BUFLEN
PARAMETER (BUFLEN=2720)
BYTE BUFFER(BUFLEN)
INTEGER*4 HEADER(2,32)
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPHEAD.FOR/NOLIST'
C
C FILESPEC -- DEC 10/20 File specification
C FSLEN -- Length of FILESPEC used
C LND -- Corrected value of length
C
CHARACTER*256 FILESPEC
INTEGER*4 FSLEN
INTEGER*4 LND
C
LND = HEADER(1,G$LND) .AND. '3FFFF'X
IF (LND.NE.0) THEN
CALL OVERHEAD(BUFFER,LND,FILESPEC,FSLEN)
ENDIF
IF (IAND(HEADER(2,G$FLAG),GF$SOF).NE.0) THEN
CALL VALIDATE(FILESPEC,FSLEN)
ENDIF
RETURN
END
SUBROUTINE POSTPROC(BUFFER,HEADER)
C
C This segment will do the post-processing of the data
C buffer. If the end of file has been reached for a
C file, the output file is closed, and the status indicating
C an open file is reset.
C
C Parameter list description:
C
C BUFFER -- Raw data from the DEC 10/20 magtape
C HEADER -- Header information after conversion
C
INTEGER*4 BUFLEN
PARAMETER (BUFLEN=2720)
BYTE BUFFER(BUFLEN)
INTEGER*4 HEADER(2,32)
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPHEAD.FOR/NOLIST'
C
IF (IAND(HEADER(2,G$FLAG),GF$EOF).NE.0) THEN
CLOSE(UNIT=1)
ENDIF
RETURN
END
SUBROUTINE DATAPROC(FILEDATA,HEADER)
C
C This segment takes the converted DEC 10/20 information
C from the FILEDATA and HEADER areas and converts it
C into the form to be used by the VAX. If the file is
C being processed in BINARY mode, each 36 bit DEC 10/20
C word is copied into 5 bytes. If the file is being
C processed in ASCII mode, each 7 bit byte is extracted
C from the DEC-10 word and put into a byte for output.
C
C Parameter list description:
C
C FILEDATA -- The converted file information
C HEADER -- The converted file header
C
INTEGER*4 FILEDATA(2,512),HEADER(2,32)
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPHEAD.FOR/NOLIST'
C
C OUTBUF -- the output buffer for the file data
C OUTLEN -- the length of output data
C
BYTE OUTBUF(2560)
INTEGER*4 OUTLEN
C
OUTLEN = 5*HEADER(1,G$SIZ)
IF (IOMODE.EQ.BINARY) THEN
CALL COPY5(FILEDATA,OUTBUF,HEADER(1,G$SIZ))
WRITE(1,100) (OUTBUF(I),I=1,OUTLEN)
100 FORMAT(4(640(A1,:),/))
ELSE
CALL COPYASC(FILEDATA,OUTBUF,HEADER(1,G$SIZ))
WRITE(1,110) (OUTBUF(I),I=1,OUTLEN)
110 FORMAT(40(64(A1,:),/))
ENDIF
RETURN
END
INTEGER*4 FUNCTION RES_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the RESTORE command action routine. It is called when
C the end of input has been found on a successful RESTORE
C command.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR'
C
EXTERNAL DUMPER_RESMAX
C
RESCNT = RESCNT+1
IF (RESCNT.GT.RESMAX) THEN
CALL ERRORM(%LOC(DUMPER_RESMAX))
ENDIF
RES_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION WHAT_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the WHAT command action routine. It is called to
C print out the files/directories that will be restored.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
DO I=1,RESCNT-1
WRITE(6,100) VAXDIR(I)(1:VAXLEN(I))
100 FORMAT('$[',A,']=[')
IF (TAPELEN(1,I).LE.0) THEN
WRITE(6,110) '*'
110 FORMAT('+',A,$)
ELSE
WRITE(6,110) TAPENAME(1,I)(1:TAPELEN(1,I))
ENDIF
DO J=2,TAPEMAX-2
IF (TAPELEN(J,I).LT.0) THEN
WRITE(6,120) '*'
120 FORMAT('+,',A,$)
ELSE IF (TAPELEN(J,I).EQ.0) THEN
GOTO 130
ELSE
WRITE(6,120) TAPENAME(J,I)(1:TAPELEN(J,I))
ENDIF
ENDDO
130 CONTINUE
IF (TAPELEN(TAPEMAX-1,I).LT.0) THEN
WRITE(6,140) '*'
140 FORMAT('+]',A,'.',$)
ELSE IF (TAPELEN(TAPEMAX-1,I).EQ.0) THEN
WRITE(6,145)
145 FORMAT('+].',$)
ELSE
WRITE(6,140) TAPENAME(TAPEMAX-1,I)(1:TAPELEN(TAPEMAX-1,I))
ENDIF
IF (TAPELEN(TAPEMAX,I).LT.0) THEN
WRITE(6,150) '*'
150 FORMAT('+',A)
ELSE IF (TAPELEN(TAPEMAX,I).EQ.0) THEN
WRITE(6,155)
155 FORMAT('+')
ELSE
WRITE(6,150) TAPENAME(TAPEMAX,I)(1:TAPELEN(TAPEMAX,I))
ENDIF
ENDDO
WHAT_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION RESET_COMMAND(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the RESET command action routine. It is called to
C reset the restore information.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
RESCNT = 1
RESET_COMMAND = 1
RETURN
END
INTEGER*4 FUNCTION RES_VDIR(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine called when the VAX filename is
C started. It will reset the data being built up. If the
C limit of names has already been reached, it will return an
C error code to be reported.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL DUMPER_RESIGN
C
C If the maximum number of restore statements have been
C processed already, return the 'ignored' message. If
C not, then clean out the current values of the restore
C information in case a previous command line aborted.
C
IF (RESCNT.GT.RESMAX) THEN
RES_VDIR = %LOC(DUMPER_RESIGN)
ELSE
VAXDIR(RESCNT) = ' '
VAXLEN(RESCNT) = 0
DO I=1,TAPEMAX
TAPENAME(I,RESCNT) = ' '
TAPELEN(I,RESCNT) = 0
ENDDO
TAPECNT = 1
RES_VDIR = 1
ENDIF
RETURN
END
INTEGER*4 FUNCTION RES_VNAME(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine called to add to the VAX
C directory name that will recieve the data.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL DUMPER_RESDNM
C
C Save the partial VAX directory name. Report an error
C if it is too long.
C
J = VAXLEN(RESCNT)
IF (J+%LOC(TLEN).GT.64) THEN
RES_VNAME = %LOC(DUMPER_RESDNM)
ELSE
DO I=1,%LOC(TLEN)
VAXDIR(RESCNT)(I+J:I+J) = CHAR(TOKEN(I))
ENDDO
VAXLEN(RESCNT) = J+%LOC(TLEN)
RES_VNAME = 1
ENDIF
RETURN
END
INTEGER*4 FUNCTION RES_VDOT(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine that is called when a period
C is seen in the VAX directory name. It will add the period
C to the current directory name being built.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL DUMPER_RESDNM
C
C If the period won't fit in the name, report an error
C
J = VAXLEN(RESCNT)+1
IF (J.GT.64) THEN
RES_VDOT = %LOC(DUMPER_RESDNM)
ELSE
VAXDIR(RESCNT)(J:J) = '.'
VAXLEN(RESCNT) = J
RES_VDOT = 1
ENDIF
RETURN
END
INTEGER*4 FUNCTION RES_TNAME(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine that is called when the
C tape name information is to be added to. It will copy
C the supplied token into the current tape name area if
C it will fit. If not, it will return an error message.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL DUMPER_RESDNM,DUMPER_RESFNM
C
IF (%LOC(TLEN).GT.32) THEN
IF (TAPECNT.GE.TAPEMAX-1) THEN
RES_TNAME = %LOC(DUMPER_RESFNM)
ELSE
RES_TNAME = %LOC(DUMPER_RESDNM)
ENDIF
ELSE
DO I=1,%LOC(TLEN)
TAPENAME(TAPECNT,RESCNT)(I:I) = CHAR(TOKEN(I))
ENDDO
TAPELEN(TAPECNT,RESCNT) = %LOC(TLEN)
RES_TNAME = 1
ENDIF
RETURN
END
INTEGER*4 FUNCTION RES_TSTAR(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine that handles the asterisk when
C found in a DEC 10/20 filename specification. It merely
C sets the length of this part of the name to -1.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
TAPELEN(TAPECNT,RESCNT) = -1
RES_TSTAR = 1
RETURN
END
INTEGER*4 FUNCTION RES_TDOT(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine called when a comma (or period)
C is seen in a DEC 10/20 directory name. It will increment
C the index into the tape name table and signal an error if
C too many sfd's have been seen.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL DUMPER_RESSFD
C
IF (TAPECNT.EQ.TAPEMAX-2) THEN
RES_TDOT = %LOC(DUMPER_RESSFD)
ELSE
TAPECNT = TAPECNT+1
RES_TDOT = 1
ENDIF
RETURN
END
INTEGER*4 FUNCTION RES_TBR(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine called to handle the right bracket
C in the tape name. It will set the index to the tape name to
C point to the filename portion.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
TAPECNT = TAPEMAX-1
RES_TBR = 1
RETURN
END
INTEGER*4 FUNCTION RES_VMIN(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine that is called when a minus
C is seen in the VAX directory name. It will add the minus
C to the current directory name being built.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
EXTERNAL DUMPER_RESDNM
C
C If the period won't fit in the name, report an error
C
J = VAXLEN(RESCNT)+1
IF (J.GT.64) THEN
RES_VMIN = %LOC(DUMPER_RESDNM)
ELSE
VAXDIR(RESCNT)(J:J) = '-'
VAXLEN(RESCNT) = J
RES_VMIN = 1
ENDIF
RETURN
END
INTEGER*4 FUNCTION SET_ASCII(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the ASCII I/O mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
IOMODE = ASCII
SET_ASCII = 1
RETURN
END
INTEGER*4 FUNCTION SET_BINARY(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the BINARY I/O mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
IOMODE = BINARY
SET_BINARY = 1
RETURN
END
INTEGER*4 FUNCTION SET_SILENT(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the SILENT mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
PRMODE = SILENT
SET_SILENT = 1
RETURN
END
INTEGER*4 FUNCTION SET_FILES(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the FILES mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
PRMODE = FILES
SET_FILES = 1
RETURN
END
INTEGER*4 FUNCTION SET_LIST(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the LISTING mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
INTEGER*4 L
CHARACTER*256 NAM
C
LIST = .TRUE.
WRITE(6,100)
100 FORMAT(' Enter the listing file name: ',$)
READ(5,110) L,NAM
110 FORMAT(Q,A)
IF (L.EQ.0) THEN
IF (LIST) CLOSE(UNIT=2)
LIST = .FALSE.
SET_LIST = %LOC(DUMPER_NOLIST)
RETURN
ENDIF
OPEN(UNIT=2,NAME=NAM(1:L),CARRIAGECONTROL='FORTRAN',ERR=120,
1 INITIALSIZE=1,EXTENDSIZE=1,RECORDSIZE=132,STATUS='NEW')
SET_LIST = 1
RETURN
120 CONTINUE
LIST = .FALSE.
SET_LIST = %LOC(DUMPER_ABLIST)
RETURN
END
INTEGER*4 FUNCTION SET_NONE(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the NONE mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
ORMODE = NONE
SET_NONE = 1
RETURN
END
INTEGER*4 FUNCTION SET_CR(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the CR mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
ORMODE = CR
SET_CR = 1
RETURN
END
INTEGER*4 FUNCTION SET_FORT(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the action routine for setting the FORTRAN mode.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
C
ORMODE = FORTRAN
SET_FORT = 1
RETURN
END
SUBROUTINE VALIDATE(FILESPEC,FSLEN)
C
C This segment will take a file specification from the
C BACKUP tape and if this is a file to remove, will then
C open the file and set FILEOK so that the
C file will be processed.
C
C Parameter list arguments:
C
C FILESPEC -- DEC 10/20 file specification
C FSLEN -- Length of the info in FILESPEC
C
CHARACTER*256 FILESPEC
INTEGER*4 FSLEN
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
EXTERNAL DUMPER_IDFE
C
C LIB$TPARSE parameter information
C
INTEGER*4 STATUS,LIB$TPARSE
INTEGER*4 TPBLOK(0:8),STRINGCNT,STRINGPTR
EXTERNAL TPA$L_COUNT,TPA$L_OPTIONS,TPA$L_STRINGCNT
EXTERNAL TPA$L_STRINGPTR,TPA$L_TOKENCNT,TPA$L_TOKENPTR
EXTERNAL TPA$B_CHAR,TPA$L_NUMBER,TPA$L_PARAM
EXTERNAL TPA$M_BLANKS,TPA$M_ABBRFM,TPA$M_ABBREV
EXTERNAL TPA$M_AMBIG,TPA$K_COUNT0
C
EXTERNAL VFINIT,VFKEY
EXTERNAL VDINIT,VDKEY
C
C Initialize part of the block
C
TPBLOK(%LOC(TPA$L_COUNT)/4) = %LOC(TPA$K_COUNT0)
TPBLOK(%LOC(TPA$L_OPTIONS)/4) = %LOC(TPA$M_ABBREV)
STRINGCNT = %LOC(TPA$L_STRINGCNT)/4
STRINGPTR = %LOC(TPA$L_STRINGPTR)/4
C
C Validate the file name
C
STELEN = 0
STNLEN = 0
FILEOK = .FALSE.
K = INDEX(FILESPEC(1:FSLEN),']')
IF (K.EQ.0) THEN
CALL ERRORM(%LOC(DUMPER_IDFE),FILESPEC(1:FSLEN))
GOVALUE = 0
RETURN
ENDIF
IF (K.EQ.CDIRLEN) THEN
IF (CURDIR(1:K).EQ.FILESPEC(1:K)) THEN
IF (NVDIR) RETURN
DO I=1,RESCNT-1
VALIDF(I) = VALIDD(I)
ENDDO
TPBLOK(STRINGCNT) = FSLEN-K
TPBLOK(STRINGPTR) = %LOC(FILESPEC(K+1:K+1))
STATUS = LIB$TPARSE(TPBLOK,VFINIT,VFKEY)
IF (STATUS) FILEOK = .TRUE.
ELSE
DO I=1,RESCNT-1
VALIDD(I) = .TRUE.
ENDDO
TPBLOK(STRINGCNT) = K
TPBLOK(STRINGPTR) = %LOC(FILESPEC)
TAPECNT = 1
STATUS = LIB$TPARSE(TPBLOK,VDINIT,VDKEY)
IF (NVDIR) RETURN
DO I=1,RESCNT-1
VALIDF(I) = VALIDD(I)
ENDDO
TPBLOK(STRINGCNT) = FSLEN-K
TPBLOK(STRINGPTR) = %LOC(FILESPEC(K+1:K+1))
STATUS = LIB$TPARSE(TPBLOK,VFINIT,VFKEY)
IF (STATUS) FILEOK = .TRUE.
ENDIF
ELSE
DO I=1,RESCNT-1
VALIDD(I) = .TRUE.
ENDDO
TPBLOK(STRINGCNT) = K
TPBLOK(STRINGPTR) = %LOC(FILESPEC)
TAPECNT = 1
STATUS = LIB$TPARSE(TPBLOK,VDINIT,VDKEY)
IF (NVDIR) RETURN
DO I=1,RESCNT-1
VALIDF(I) = VALIDD(I)
ENDDO
TPBLOK(STRINGCNT) = FSLEN-K
TPBLOK(STRINGPTR) = %LOC(FILESPEC(K+1:K+1))
STATUS = LIB$TPARSE(TPBLOK,VFINIT,VFKEY)
IF (STATUS) FILEOK = .TRUE.
ENDIF
IF (FILEOK.AND.(PRMODE.EQ.FILES)) WRITE(*,10) FILESPEC(1:FSLEN)
10 FORMAT(' Created from ',A)
RETURN
END
INTEGER*4 FUNCTION VAL_DIR(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the segment that validates directory names from
C the magtape.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
LOGICAL COMPBS
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
VAL_DIR = 0
NVDIR = .FALSE.
DO I=1,RESCNT-1
IF (VALIDD(I)) THEN
IF (TAPELEN(TAPECNT,I).EQ.0) THEN
VALIDD(I) = .FALSE.
ELSE IF (TAPELEN(TAPECNT,I).GT.0) THEN
IF (TAPELEN(TAPECNT,I).EQ.%LOC(TLEN)) THEN
IF (COMPBS(TAPELEN(TAPECNT,I),TOKEN,TAPENAME(TAPECNT,I))) THEN
TAPECNT = TAPECNT+1
ELSE
VALIDD(I) = .FALSE.
ENDIF
ELSE
VALIDD(I) = .FALSE.
ENDIF
ENDIF
NVDIR = NVDIR .OR. VALIDD(I)
ENDIF
ENDDO
IF (NVDIR) VAL_DIR = 1
NVDIR = .NOT.NVDIR
RETURN
END
INTEGER*4 FUNCTION VAL_NAME(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the segment that validates the file name from
C the magtape.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
LOGICAL COMPBS
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
VAL_NAME = 0
DO I=1,RESCNT-1
IF (VALIDD(I)) THEN
IF (TAPELEN(TAPEMAX-1,I).EQ.0) THEN
VALIDF(I) = .FALSE.
ELSE IF (TAPELEN(TAPEMAX-1,I).GT.0) THEN
IF (TAPELEN(TAPEMAX-1,I).EQ.%LOC(TLEN)) THEN
IF (.NOT.COMPBS(TAPELEN(TAPEMAX-1,I),TOKEN,TAPENAME(TAPEMAX-1,I)))
1 VALIDF(I) = .FALSE.
ELSE
VALIDF(I) = .FALSE.
ENDIF
ENDIF
IF (VALIDF(I)) VAL_NAME = 1
ENDIF
ENDDO
IF (VAL_NAME.EQ.1) THEN
STNLEN = MIN(9,%LOC(TLEN))
DO I=1,STNLEN
STNAME(I:I) = CHAR(TOKEN(I))
ENDDO
ENDIF
RETURN
END
INTEGER*4 FUNCTION VAL_EXT(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the segment that validates the extension from
C the magtape.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
LOGICAL COMPBS
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
VAL_EXT = 0
DO I=1,RESCNT-1
IF (VALIDD(I)) THEN
IF (TAPELEN(TAPEMAX,I).EQ.0) THEN
VALIDF(I) = .FALSE.
ELSE IF (TAPELEN(TAPEMAX,I).GT.0) THEN
IF (TAPELEN(TAPEMAX,I).EQ.%LOC(TLEN)) THEN
IF (.NOT.COMPBS(TAPELEN(TAPEMAX,I),TOKEN,TAPENAME(TAPEMAX,I)))
1 VALIDF(I) = .FALSE.
ELSE
VALIDF(I) = .FALSE.
ENDIF
ENDIF
IF (VALIDF(I)) VAL_EXT = 1
ENDIF
ENDDO
IF (VAL_EXT.EQ.1) THEN
STELEN = MIN(3,%LOC(TLEN))
DO I=1,STELEN
STEXT(I:I) = CHAR(TOKEN(I))
ENDDO
ENDIF
RETURN
END
INTEGER*4 FUNCTION VAL_OPEN(OPTION,SLEN,STRING,TLEN,
1 TOKEN,CHARX,NUMBER,PARAM)
C
C This is the segment that opens the output file
C after validating the names.
C
C Parameter list description:
C
C OPT -- Options given to LIB$TPARSE
C SLEN -- Length of remaining string
C STRING -- Address of remaining string
C TLEN -- Length of the matched token
C TOKEN -- Address of the matched token
C CHARX -- Character matched by a single letter type
C NUMBER -- Integer value of a matched numeric type
C PARAM -- Parameter supplied by state transition
C
INTEGER*4 OPTION,SLEN,TLEN,NUMBER,PARAM
BYTE STRING(1),TOKEN(1),CHARX
C
INCLUDE 'DMPCOM.FOR/NOLIST'
INCLUDE 'DMPRES.FOR/NOLIST'
C
LOGICAL FAIL
CHARACTER*1 ANS
CHARACTER*256 VAXSPEC
INTEGER*4 VSLEN
CHARACTER*7 CC(0:2)
INTEGER*4 RS(0:1)
C
DATA RS/64,640/
DATA CC/'NONE','LIST','FORTRAN'/
C
VAL_OPEN = 0
FAIL = .FALSE.
DO I=1,RESCNT
IF (VALIDF(I)) THEN
VSLEN = 3+VAXLEN(I)+STNLEN+STELEN
VAXSPEC(1:VSLEN) = '[' // VAXDIR(I)(1:VAXLEN(I)) // ']' //
1 STNAME(1:STNLEN) // '.' // STEXT(1:STELEN)
OPEN(UNIT=1,NAME=VAXSPEC(1:VSLEN),STATUS='NEW',ERR=50,
1 CARRIAGECONTROL=CC(ORMODE),RECORDSIZE=RS(IOMODE),
2 INITIALSIZE=1,EXTENDSIZE=1)
VAL_OPEN = 1
IF (PRMODE.EQ.FILES) WRITE(*,10) VAXSPEC(1:VSLEN)
10 FORMAT(' Creating ',A)
GOTO 200
50 CONTINUE
FAIL = .TRUE.
WRITE(*,60) VAXSPEC(1:VSLEN)
60 FORMAT(' Error creating ',A)
ENDIF
ENDDO
C
IF (FAIL) THEN
70 WRITE(*,80)
80 FORMAT(' Errors occurred, enter S to skip this file, A to',/,
1 ' abort the processing, or F to enter a filename: ',$)
READ(5,90) ANS
90 FORMAT(A)
IF ((ANS.EQ.'S').OR.(ANS.EQ.'s')) GOTO 200
IF ((ANS.EQ.'A').OR.(ANS.EQ.'a')) THEN
GO_VALUE = 0
RETURN
ENDIF
IF ((ANS.NE.'F').AND.(ANS.NE.'f')) GOTO 70
WRITE(*,100)
100 FORMAT(' Enter filename: ',$)
READ(5,110) VSLEN,VAXSPEC
110 FORMAT(Q,A)
OPEN(UNIT=1,NAME=VAXSPEC(1:VSLEN),STATUS='NEW',ERR=70,
1 CARRIAGECONTROL=CC(ORMODE),RECORDSIZE=RS(IOMODE),
2 INITIALSIZE=1,EXTENDSIZE=1)
VAL_OPEN = 1
IF (PRMODE.EQ.FILES) WRITE(*,10) VAXSPEC(1:VSLEN)
ENDIF
200 CONTINUE
RETURN
END