!***********************************************************************
!*
!* Program to write a VOLUMS-format tape
!*
!* Adapted from ERCC program
!* R.D. Eager University of Kent MCMLXXX
!*
!***********************************************************************
!
CONSTINTEGER VERSION = 6; ! Major version number
CONSTINTEGER EDIT = 0; ! Edit number within major version
!
!***********************************************************************
!*
!* Constants
!*
!***********************************************************************
!
CONSTINTEGER NO = 0, YES = 1
CONSTINTEGER LISTCHAN = 80; ! Channel for listing of files written
CONSTINTEGER MAXCHAP = 5000; ! Max number of chapters on a tape
CONSTSTRING (1) SNL = "
"
CONSTINTEGER KEYMAX = 5; ! Number of parameter keywords
CONSTSTRING (9)ARRAY KEYS(1:KEYMAX) = C
"TAPE",
"STARTCHAP",
"LISTING",
"TYPE",
"VERSION"
!
!***********************************************************************
!*
!* Record formats
!*
!***********************************************************************
!
RECORDFORMAT FRF(INTEGER CONAD,FILETYPE,DATASTART,DATAEND,C
SIZE,RUP,EEP,MODE,USERS,ARCH,STRING (6) TRAN,C
STRING (8) DATE,TIME,INTEGER COUNT,SPARE1,SPARE2)
RECORDFORMAT HF(INTEGER DATAEND,DATASTART,FILESIZE,FILETYPE,C
SUM,DATETIME,FORMAT,RECORDS)
RECORDFORMAT HPF(STRING (6) TAPENAME,USERNAME,STRING (15) FILENAME,C
STRING (8) DATE,TIME,TYPE,BYTEINTEGER SPARE0,C
SPARE1,SPARE2,INTEGER CHAPTER,EPAGES,FSYS,PERMS,C
OWN,EEP,ARCH,CODES,SSBYTE,CCT,SPARE3,SPARE4,SPARE5,C
RECORDS,STRING (6) OFFERED TO)
RECORDFORMAT RF(INTEGER CONAD,FILETYPE,DATASTART,DATAEND)
!
!
!***********************************************************************
!*
!* Subsystem references
!*
!***********************************************************************
!
SYSTEMROUTINESPEC CONNECT(STRING (31) FILE,INTEGER MODE,HOLE,C
PROT,RECORDNAME R,INTEGERNAME FLAG)
EXTERNALSTRINGFNSPEC DATE
SYSTEMROUTINESPEC DISCONNECT(STRING (31) FILE,INTEGERNAME FLAG)
SYSTEMSTRINGFNSPEC FAILUREMESSAGE(INTEGER MESS)
SYSTEMROUTINESPEC FILL(INTEGER LENGTH,FROM,FILLER)
SYSTEMROUTINESPEC FINFO(STRING (31) FILE,INTEGER MODE,C
RECORDNAME FR,INTEGERNAME FLAG)
SYSTEMSTRINGFNSPEC ITOS(INTEGER N)
SYSTEMROUTINESPEC MOVE(INTEGER LENGTH,FROM,TO)
EXTERNALINTEGERFNSPEC OUTPOS
EXTERNALROUTINESPEC PROMPT(STRING (255) S)
SYSTEMINTEGERFNSPEC PSTOI(STRING (63) S)
SYSTEMROUTINESPEC SETFNAME(STRING (63) S)
EXTERNALROUTINESPEC SET RETURN CODE(INTEGER I)
EXTERNALSTRINGFNSPEC TIME
SYSTEMROUTINESPEC UCTRANSLATE(INTEGER AD,LEN)
EXTERNALSTRINGFNSPEC UINFS(INTEGER ENTRY)
!
EXTERNALROUTINESPEC DEFINE(STRING (255) S)
!
!
!***********************************************************************
!*
!* Magnetic tape interface routines
!*
!***********************************************************************
!
EXTERNALROUTINESPEC ASKMT(STRING (7) VOL,INTEGERNAME FLAG)
EXTERNALROUTINESPEC REWINDMT
EXTERNALROUTINESPEC SKIPTMMT(INTEGER N)
EXTERNALROUTINESPEC SKIPMT(INTEGER N)
EXTERNALROUTINESPEC WRITEMT(INTEGER AD,LEN,INTEGERNAME FLAG)
EXTERNALROUTINESPEC WRITETMMT(INTEGERNAME FLAG)
EXTERNALROUTINESPEC UNLOADMT
!
!
!***********************************************************************
!*
!* Service routines
!*
!***********************************************************************
!
INTEGERFN MATCHSTRINGS(STRINGNAME A,STRING (255) B)
INTEGER L
!
L = LENGTH(A)
IF LENGTH(B) < L THEN RESULT = 0
LENGTH(B) = L
IF A = B THEN RESULT = YES ELSE RESULT = NO
END ; ! of MATCHSTRINGS
!
!
INTEGERFN PARAMDECODE(STRING (255) PARAM,INTEGER PMAX,C
STRINGARRAYNAME KEYS,PARS)
INTEGER I,PNUM,PN,RES,C,PARPTR,PARLENG
STRING (255) WKSP
!
INTEGERFN FINDKEY
INTEGER F,I
!
IF LENGTH(WKSP) = 0 THEN RESULT = -2; ! Missing keyword
F = 0
CYCLE I = 1,1,PMAX
IF MATCHSTRINGS(WKSP,KEYS(I)) = YES THEN START
UNLESS F = 0 THEN RESULT = -1
F = I
FINISH
REPEAT
RESULT = F
END ; ! of FINDKEY
!
INTEGERFN GETPAR
INTEGER C,INPR
!
INPR = 0
WKSP = ""
!
CYCLE
PARPTR = PARPTR + 1
IF PARPTR > PARLENG THEN RESULT = -1
C = CHARNO(PARAM,PARPTR)
IF C = ',' OR C = '=' THEN RESULT = C
WKSP = WKSP.TOSTRING(C)
REPEAT
END ; ! of GETPAR
!
CYCLE I = 1,1,PMAX
PARS(I) = ""; ! Initialise
REPEAT
PARPTR = 0
PNUM = 1
PARLENG = LENGTH(PARAM)
!
CYCLE
C = GETPAR
RES = 0
IF C # '=' THEN START
PN = PNUM
FINISH ELSE START
PN = FINDKEY
IF PN = 0 THEN RES = 322; ! Unknown keyword
IF PN = -1 THEN RES = 321; ! Ambiguous keyword
IF PN = -2 THEN RES = 325; ! Missing keyword
C = GETPAR
IF C = '=' THEN RES = 320; ! Format error
FINISH
IF PN > PMAX THEN RES = 323; ! Too many parameters
IF RES = 0 THEN START
IF WKSP # "" # PARS(PN) THEN RES = 324
! Duplicated parameter
PARS(PN) = WKSP
FINISH
IF RES # 0 THEN RESULT = RES
IF C = -1 THEN RESULT = 0; ! Finished, all OK
PNUM = PNUM + 1
REPEAT
END ; ! of PARAMDECODE
!
!
STRING (63)FN SPECMESSAGE(INTEGER N)
SWITCH MES(1000:1001)
!
-> MES(N)
!
MES(1000): RESULT = "Failed to claim tape"
MES(1001): RESULT = "Tape write error"
END ; ! of SPECMESSAGE
!
!
ROUTINE FAIL(INTEGER N)
SELECTOUTPUT(0)
PRINTSTRING(SNL."WRITEVTAPE fails - ")
IF N < 1000 THEN START
PRINTSTRING(FAILUREMESSAGE(N))
FINISH ELSE START
PRINTSTRING(SPECMESSAGE(N).SNL)
FINISH
SET RETURN CODE(N)
STOP
END ; ! of FAIL
!
!
ROUTINE READLINE(STRINGNAME S)
INTEGER C
!
S = ""
CYCLE
CYCLE
READSYMBOL(C)
EXIT IF C = NL
S <- S.TOSTRING(C)
REPEAT
!
WHILE LENGTH(S) > 0 CYCLE
C = CHARNO(S,LENGTH(S))
EXIT UNLESS C = ' '
LENGTH(S) = LENGTH(S) - 1
REPEAT
!
EXIT UNLESS LENGTH(S) = 0
REPEAT
UCTRANSLATE(ADDR(S)+1,LENGTH(S))
END ; ! of READLINE
!
!
ROUTINE WARN(STRING (255) S)
SELECTOUTPUT(0)
PRINTSTRING(S)
SELECTOUTPUT(LISTCHAN)
PRINTSTRING(S)
END ; ! of WARN
!
!
ROUTINE FIXUSER(STRINGNAME S)
IF LENGTH(S) < 8 OR CHARNO(S,7) # '.' THEN START
S <- UINFS(1).".".S
FINISH
END ; ! of FIXUSER
!
!
!***********************************************************************
!*
!* W R I T E V T A P E
!*
!***********************************************************************
!
EXTERNALROUTINE WRITEVTAPE(STRING (255) PARMS)
STRINGNAME VOL,CS,OUT,TYPE,VS
INTEGER AD,FLAG,STARTCHAP,CHAPTER,CONAD,EPAGES,REMAINDER,FAILURES,PD,I
INTEGER NBYTES
STRING (6) USER
STRING (63) LINE,INPUT,OUTPUT,FILE,WORK
RECORD FR(FRF)
RECORD RR(RF)
RECORDNAME R(HF)
RECORDNAME H(HPF)
STRING (255)ARRAY OPTIONS(1:KEYMAX)
BYTEINTEGERARRAY BUF(0:4095)
!
SET RETURN CODE(1000); ! In case of catastrophic failure
FLAG = PARAMDECODE(PARMS,KEYMAX,KEYS,OPTIONS)
IF FLAG # 0 THEN FAIL(FLAG)
VOL == OPTIONS(1)
CS == OPTIONS(2)
OUT == OPTIONS(3)
TYPE == OPTIONS(4)
VS == OPTIONS(5)
!
IF VOL = "" THEN FAIL(263); ! Wrong number of parameters
UNLESS 1 <= LENGTH(VOL) <= 6 THEN START
SETFNAME(KEYS(1))
FAIL(326); ! Invalid value for TAPE parameter
FINISH
!
IF CS # "" THEN START ; ! Starting chapter specified
STARTCHAP = PSTOI(CS)
UNLESS 1 <= STARTCHAP <= MAXCHAP THEN START
SETFNAME(KEYS(2))
FAIL(326); ! Invalid value for STARTCHAP parameter
FINISH
FINISH ELSE STARTCHAP = 1
!
IF OUT = "" THEN OUT = "T#LIST"
!
IF TYPE = "" THEN TYPE = "TRANSFER"
UNLESS 1 <= LENGTH(TYPE) <= 8 THEN START
SETFNAME(KEYS(4))
FAIL(326); ! Invalid value for TYPE parameter
FINISH
!
IF VS # "" THEN START
IF MATCHSTRINGS(VS,"NO") = NO THEN START
IF MATCHSTRINGS(VS,"YES") = YES THEN START
PRINTSTRING("Version: E".ITOS(VERSION).".".ITOS(EDIT).SNL)
FINISH ELSE START
SETFNAME(KEYS(5))
FAIL(326); ! Invalid value for VERSION parameter
FINISH
FINISH
FINISH
!
ASKMT(VOL."*",FLAG)
IF FLAG # 0 THEN START
SETFNAME(VOL)
FAIL(1000)
FINISH
REWINDMT
!
AD = ADDR(BUF(0))
H == RECORD(AD)
!
DEFINE(ITOS(LISTCHAN).",".OUT)
SELECTOUTPUT(LISTCHAN)
NEWLINES(2)
PRINTSTRING("EMAS 2900 VTAPE written at ".TIME." on ".DATE.C
" - volume label ".VOL)
NEWLINES(2)
!
IF STARTCHAP = 1 THEN START
SKIPMT(1); ! Skip volume label
WRITETMMT(FLAG)
-> TAPEERR IF FLAG # 0
FINISH ELSE SKIPTMMT(STARTCHAP)
!
CHAPTER = STARTCHAP - 1
FAILURES = 0
CYCLE
PROMPT("File: ")
READLINE(LINE)
EXIT IF LINE = ".END"
IF CHARNO(LINE,LENGTH(LINE)) = ')' THEN START
LENGTH(LINE) = LENGTH(LINE) - 1
UNLESS LINE -> INPUT.("(").OUTPUT THEN START
LINE <- LINE.")"
WARN(LINE.SNL)
WARN("Wrong format - use 'file' or 'file(newfile)'".SNL)
FAILURES = FAILURES + 1
CONTINUE
FINISH
FINISH ELSE START
INPUT = LINE
OUTPUT = LINE
FINISH
FIXUSER(OUTPUT)
IF OUTPUT -> USER.(".").LINE.("_").WORK THEN START
OUTPUT = USER.".".WORK; ! Remove any pdfile name
FINISH
FIXUSER(INPUT)
IF INPUT -> LINE.("_") THEN START
PD = YES
FINISH ELSE START
LINE = INPUT
PD = NO
FINISH
FINFO(LINE,1,FR,FLAG)
IF FLAG = 0 THEN START
CONNECT(INPUT,1,0,0,RR,FLAG)
FINISH
IF FLAG # 0 THEN START
WARN("Warning - ".FAILUREMESSAGE(FLAG))
FAILURES = FAILURES + 1
CONTINUE
FINISH
CONAD = RR_CONAD
R == RECORD(CONAD)
EPAGES = (R_DATAEND+4095)//4096
REMAINDER = R_DATAEND - (EPAGES-1)*4096; ! Length of information in last epage
!
! Set up header page
!
CHAPTER = CHAPTER + 1
FILL(4096,AD,0); ! Clear page
H_TAPENAME = VOL
H_USERNAME = FROMSTRING(OUTPUT,1,6)
H_FILENAME = FROMSTRING(OUTPUT,8,LENGTH(OUTPUT))
H_DATE = DATE
H_TIME = TIME
H_TYPE = TYPE
H_CHAPTER = CHAPTER
H_EPAGES = EPAGES
H_FSYS = -1
H_PERMS = 1; ! Permissions are included
H_OWN = FR_RUP; ! Take from input file
H_EEP = FR_EEP; ! Take from input file
H_CODES = (FR_ARCH & 1) << 4; ! Preserve CHERISH status
!
! Write the header page
!
WRITEMT(AD,4096,FLAG)
-> TAPEERR IF FLAG # 0
!
! Copy the file itself
!
CYCLE I = 1,1,EPAGES
IF I = EPAGES AND REMAINDER # 0 AND PD = YES THEN START
NBYTES = REMAINDER; ! Last and incomplete page of pdfile member
FILL(4096,AD,0); ! Clear buffer page
FINISH ELSE NBYTES = 4096
MOVE(NBYTES,CONAD+4096*(I-1),AD)
WRITEMT(AD,4096,FLAG)
-> TAPEERR IF FLAG # 0
REPEAT
!
WRITETMMT(FLAG)
!
-> TAPEERR IF FLAG # 0
PRINTSTRING(INPUT)
SPACES(32-OUTPOS)
PRINTSTRING("written as ".OUTPUT)
SPACES(62-OUTPOS)
PRINTSTRING(" Chapter =")
WRITE(CHAPTER,1)
SPACES(79-OUTPOS)
PRINTSTRING(" Pages =")
WRITE(EPAGES,1)
NEWLINE
DISCONNECT(INPUT,FLAG)
REPEAT
!
WRITETMMT(FLAG); ! Double tape mark to terminate
-> TAPEERR IF FLAG # 0
!
SELECTOUTPUT(0)
CLOSE STREAM(LISTCHAN)
IF FAILURES # 0 THEN START
PRINTSTRING(ITOS(FAILURES)." file")
IF FAILURES # 1 THEN PRINTSYMBOL('s')
PRINTSTRING(" failed to transfer".SNL)
FINISH
PRINTSTRING("Tape written".SNL)
UNLOADMT
SET RETURN CODE(-FAILURES)
STOP
!
TAPEERR:
!
UNLOADMT
FAIL(1001); ! Tape write error
END ; ! of VTAPE
ENDOFFILE